Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

In Excel > I would like to create a macro to copy multiple rows to 1 row on another excel spreads

Status
Not open for further replies.
gennaroalpha7

gennaroalpha7

Technical User
Nov 28, 2012
253
0
0
US
Hi -

I would like to create a macro to copy (4 or 5) multiple rows to 1 row on another excel spreadsheet. Can this be completed.

Pleas be specific and elaborate - I have never created a macro before...help!


Thx.

G.
 
Sort by date Sort by votes
Hi,

Try this:

1) turn on your Macro Recorder
2) SELECT and COPY the range of interest
3) Select the target sheet
4) Select the target cell on the target sheet
5) ctr+v to PASTE
6) turn off your macro recorder

alt+F11 toggles between your active sheet and the VBA Editor

You may need to modify this code. If so, post back for help.

Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
 
Upvote 0 Downvote
Hi -

Here's what I have to do. I have a spreadsheet with like a gob of rows that I have to paste on another spreadsheet. I think its about 2k rows, and I have to paste 4 or 5 rows in one row on the other spreadsheet.

I tried your suggestion and except it pasted the four rows, like the source sheet, to the target sheet. the rows consist of 5 colonms of data - it also pasted 15 more colomns with the same data. so now i have 4 rows down and 20 columns. instead of 4 rows with 5 colomns.

thank for your help.

G
 
Upvote 0 Downvote
???

You want multiple rows copied into ONE ROW?

How does that work?

What is the business case for this requirement?

If your source table has ONLY 5 columns of data AND no columns are hidden, you will only get 5 columns of data in the PASTE.

Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
 
Upvote 0 Downvote
If this is not a joke, maybe you want to paste the data from five cells into a single cell, the rows from original source being separated in the targeted cell with a ALT+SPACE?

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote
Sorry, I mean Alt+Enter

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote
Hello =

Please view the file. I have to copy all the related numbers, they are in multiple rows now, into one row, top sheet, in the other spreadsheet. I have already copied a bunch of them, but this is very time consuming. Is there a faster method - perhaps a macro?


Here is the file. Please follow the drop box link.



Thanks.

G.
 
Upvote 0 Downvote
You never stated your business case, which I asked several posts ago.

How do you determine the range to "copy"?

Please answer both these questions.

Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
 
Upvote 0 Downvote

I am confused!

Your PICTURE (not a spreadsheet tat can be investigated) shows A133:F133 copied to A320:AJ320.

So are columns B:AE HIDDEN? Is that the issue?

Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
 
Upvote 0 Downvote
Code: 
Private Sub compact()
    Dim nCurRow As Integer
    Dim nRowsCompact As Integer
    Dim nCurCol As Integer
    Dim nDestRow As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    'Workbooks("EM Contact v.01.xlsm").Activate
    Set wsSource = Workbooks("EM Contact v.01.xlsm").Worksheets("EM Contact")
    Set wsDest = Workbooks("Branch Emergency Contact List V.01.xlsx").Worksheets("Final")
    nRowsCompact = 5 ' how many source rows goes into a single destination row
    With wsSource.Cells(1, 1).CurrentRegion
        ' Copy the columns header
        wsDest.Cells(1, 1).Value = 1
        For nCurRow = 1 To nRowsCompact
            For nCurCol = 2 To .Columns.Count
                wsDest.Cells(1, (nCurRow - 1) * (.Columns.Count - 1) + nCurCol).Value = wsSource.Cells(1, nCurCol).Value
            Next
        Next
        ' Copy the columns
        For nCurRow = 2 To .Rows.Count
            nDestRow = (nCurRow - 2) \ nRowsCompact + 2
            wsDest.Cells(nDestRow, 1).Value = nDestRow
            For nCurCol = 2 To .Columns.Count
                wsDest.Cells(nDestRow, ((nCurRow - 2) Mod nRowsCompact) * (.Columns.Count - 1) + nCurCol).Value = wsSource.Cells(nCurRow, nCurCol).Value
            Next
        Next
    End With
End Sub

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote
Sorry for the column headers, it's was early in the morning

Code: 
Private Sub compact()
    Dim nCurRow As Integer
    Dim nRowsCompact As Integer
    Dim nCurCol As Integer
    Dim nDestRow As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim cColHead As String
    Dim vColSplit As Variant
    
    Set wsSource = Workbooks("EM Contact v.01.xlsm").Worksheets("EM Contact")
    Set wsDest = Workbooks("Branch Emergency Contact List V.01.xlsx").Worksheets("Final")
    nRowsCompact = 5 ' how many source rows goes into a single destination row
    With wsSource.Cells(1, 1).CurrentRegion
        ' Copy the columns header
        wsDest.Cells(1, 1).Value = wsSource.Cells(1, 1).Value
        For nCurRow = 1 To nRowsCompact
            For nCurCol = 2 To .Columns.Count
                vColSplit = Split(wsSource.Cells(1, nCurCol).Value)
                cColHead = vColSplit(0) & " " & nCurRow & Mid(wsSource.Cells(1, nCurCol).Value, Len(vColSplit(0)) + 1)
                wsDest.Cells(1, (nCurRow - 1) * (.Columns.Count - 1) + nCurCol).Value = cColHead
            Next
        Next
        ' Copy the columns
        For nCurRow = 2 To .Rows.Count
            nDestRow = (nCurRow - 2) \ nRowsCompact + 2
            wsDest.Cells(nDestRow, 1).Value = nDestRow
            For nCurCol = 2 To .Columns.Count
                wsDest.Cells(nDestRow, ((nCurRow - 2) Mod nRowsCompact) * (.Columns.Count - 1) + nCurCol).Value = wsSource.Cells(nCurRow, nCurCol).Value
            Next
        Next
    End With
End Sub

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote
Hi, the range to copy is based on the branch numbers on the left hand side. For example, all the (people) contacts from branch 714 or whatever one shows on the example, which are in multiple rows would be copied to the new spreadsheet, but into one row instead of multiple rows. some branches have 2, 3, or 4 contacts. The contact field/cells are first name, last name, postion, home ph, cell ph. as in the example i have given. Alas, it appears there's no easy way of doing this...a sigh....another sigh.....

the biz case is that they want this on an excel spreadsheet, because right now it's in access and they cannot get that to sharepoint - so they want it like this on excel.

Vilhelm-Ion Praisach, you've shown some massive code, how do i use that and how do enter that in excel. I have never used vb in excel or have every created a macro, because I have never needed to.

Thanks for your help.

G.
 
Upvote 0 Downvote
I can attach the spread sheets as well if that will help...let me know...

Thanks.

G.
 
Upvote 0 Downvote
Yes

Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
 
Upvote 0 Downvote
I assume the first column (Branch #) is a string

Code: 
Private Sub compact1()
    Dim nCurRow As Integer
    Dim nCurCol As Integer
    Dim nDestRow As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim cColHead As String
    Dim vColSplit As Variant
    Dim lcBranch As String ' current branch
    Dim nBranchRow As Integer ' count the members / current branch for columns header
    Dim nBranchRowMax As Integer ' count the max number of members / branch for columns header
    
    Set wsSource = Workbooks("EM Contact v.01.xlsm").Worksheets("EM Contact")
    Set wsDest = Workbooks("Branch Emergency Contact List V.01.xlsx").Worksheets("Final")
    With wsSource.Cells(1, 1).CurrentRegion
        ' Copy the columns
        nDestRow = 1
        nBranchRowMax = 0
        For nCurRow = 2 To .Rows.Count
            If IsEmpty(lcBranch) Then ' first branch
                nDestRow = 1
                lcBranch = wsSource.Cells(nCurRow, 1).Value
                nBranchRow = 0
            End If
            If lcBranch <> wsSource.Cells(nCurRow, 1).Value Then ' New Branch
                lcBranch = wsSource.Cells(nCurRow, 1).Value
                nDestRow = nDestRow + 1 ' New destination row
                If nBranchRowMax < nBranchRow Then
                    nBranchRowMax = nBranchRow
                End If
                nBranchRow = 0
            Else ' new member of the same branch
                nBranchRow = nBranchRow + 1
            End If
            If nCurRow = .Rows.Count Then ' last branch
                If nBranchRowMax < nBranchRow Then
                    nBranchRowMax = nBranchRow
                End If
            End If
            wsDest.Cells(nDestRow, 1).Value = wsSource.Cells(nCurRow, 1)
            For nCurCol = 2 To .Columns.Count
                wsDest.Cells(nDestRow, nBranchRow * (.Columns.Count - 1) + nCurCol).Value = wsSource.Cells(nCurRow, nCurCol).Value
            Next
        Next
        ' Copy the columns header
        wsDest.Cells(1, 1).Value = wsSource.Cells(1, 1).Value
        For nCurRow = 1 To nBranchRowMax + 1
            For nCurCol = 2 To .Columns.Count
                vColSplit = Split(wsSource.Cells(1, nCurCol).Value)
                cColHead = vColSplit(0) & " " & nCurRow & Mid(wsSource.Cells(1, nCurCol).Value, Len(vColSplit(0)) + 1)
                wsDest.Cells(1, (nCurRow - 1) * (.Columns.Count - 1) + nCurCol).Value = cColHead
            Next
        Next
    End With
End Sub

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote


Vilhelm-Ion Praisach, in reference to your comment 'I assume the first column (Branch #) is a string'. I dont know, it's a cell that was typed into. But, it's formatted as 'General' - to right click on it > Format Cell > Number Tab

Thx.

G.

 
Upvote 0 Downvote
Your pictures confuses me.
Do you want to add some cells from one sheet to the right side of another?
What about the empty cells from the source?
How do you treat the cells already completed in the destination? Do you overwrite them, even if in the source you have empty rows?

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote
Yes, just as I showed in the first picture post. The source cells should be copied and not deleted. We are just copyiing the contacts from the source to target source, except when we go to the target, all the rows, 2, 3, or 4 contacts, go to one row. as shown. Nothing is overwritten, for example all the 714 contacts are copied to one empty row, then the next number or branch is copied to the empty row below the one that was just copied to.

Thanks.

G
 
Upvote 0 Downvote
It's easy to add an offset.

Code: 
Private Sub compact1()
    Dim nCurRow As Integer
    Dim nCurCol As Integer
    Dim nDestRow As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim cColHead As String
    Dim vColSplit As Variant
    Dim lcBranch As String ' current branch
    Dim nBranchRow As Integer ' count the members / current branch for columns header
    Dim nBranchRowMax As Integer ' count the max number of members / branch for columns header
    Dim nColOffset As Integer
    nColOffset = 30
    
    Set wsSource = Workbooks("EM Contact v.01.xlsm").Worksheets("EM Contact")
    Set wsDest = Workbooks("Branch Emergency Contact List V.01.xlsx").Worksheets("Final")
    With wsSource.Cells(1, 1).CurrentRegion
        ' Copy the columns
        'lcBranch = ""
        nDestRow = 1
        nBranchRowMax = 0
        For nCurRow = 2 To .Rows.Count
            If IsEmpty(lcBranch) Then ' first branch
                nDestRow = 1
                lcBranch = wsSource.Cells(nCurRow, 1).Value
                nBranchRow = 0
            End If
            If lcBranch <> wsSource.Cells(nCurRow, 1).Value Then ' New Branch
                lcBranch = wsSource.Cells(nCurRow, 1).Value
                nDestRow = nDestRow + 1 ' New destination row
                If nBranchRowMax < nBranchRow Then
                    nBranchRowMax = nBranchRow
                End If
                nBranchRow = 0
            Else ' new member of the same branch
                nBranchRow = nBranchRow + 1
            End If
            If nCurRow = .Rows.Count Then ' last branch
                If nBranchRowMax < nBranchRow Then
                    nBranchRowMax = nBranchRow
                End If
            End If
            wsDest.Cells(nDestRow, 1).Value = wsSource.Cells(nCurRow, 1)
            For nCurCol = 2 To .Columns.Count
                wsDest.Cells(nDestRow, nBranchRow * (.Columns.Count - 1) + nCurCol + nColOffset).Value = wsSource.Cells(nCurRow, nCurCol).Value
            Next
        Next
        ' Copy the columns header
        wsDest.Cells(1, 1).Value = wsSource.Cells(1, 1).Value
        For nCurRow = 1 To nBranchRowMax + 1
            For nCurCol = 2 To .Columns.Count
                vColSplit = Split(wsSource.Cells(1, nCurCol).Value)
                cColHead = vColSplit(0) & " " & nCurRow & Mid(wsSource.Cells(1, nCurCol).Value, Len(vColSplit(0)) + 1)
                wsDest.Cells(1, (nCurRow - 1) * (.Columns.Count - 1) + nCurCol + nColOffset).Value = cColHead
            Next
        Next
    End With
End Sub

My respects,
Vilhelm-Ion Praisach
Resita, Romania
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

duytoi
  • Locked
  • Question
How to add a head to the search results in Excel 2016 using VBA
Replies
2
Views
518
Andrzejek
Andrzejek
Flavescent
  • Locked
  • Question
Excel 365 - like a cut out figure
Replies
4
Views
115
SkipVought
S
navyasree
  • Locked
  • Question
Need to update excel on making changes in visio flowcharts 1
Replies
4
Views
117
Andrzejek
Andrzejek
Bijugate
  • Question
Excel update question
Replies
0
Views
108
Bijugate
Bijugate
Pirouette
  • Locked
  • Question
Excel workbook
Replies
1
Views
133
combo
combo

Part and Inventory Search

Sponsor

Back
Top