Copy from other sheets into one sheet

[chrisellis250]

Hi all,

I've got the following code, which copies data from other sheets within the same workbook. The idea is to place the data into one table, with the data from the next sheet going into the next empty cell etc etc.

Sub CopyPivot()

Dim cell As Range
Dim i As Long
i = Sheets("Shared Contact Pivot").Cells(Rows.Count, "B").End(xlUp).Row + 1
For Each cell In Sheets("CPA 1").Range("B2:D" & Sheets("CPA 1").Cells(Rows.Count, "B").End(xlUp).Row)
    If cell.Value <> "" Then
        Sheets("Shared Contact Pivot").Range("B" & i).Value = cell.Value
        i = i + 1
    End If
    On Error Resume Next
    
Next cell

i = Sheets("Shared Contact Pivot").Cells(Rows.Count, "B").End(xlUp).Row + 1
For Each cell In Sheets("CPA 2").Range("B2:D" & Sheets("CPA 2").Cells(Rows.Count, "B").End(xlUp).Row)
    If cell.Value <> "" Then
        Sheets("Shared Contact Pivot").Range("B" & i).Value = cell.Value
        i = i + 1
    End If
    On Error Resume Next
    
Next cell

End Sub

I've gone wrong somewhere, as it is copying it all into one column (B) as opposed to copying across B, C and D.

Any ideas?

[Mumps1]

Try: (untested)

Sub CopyPivot()
    Application.ScreenUpdating = False
    Dim cel As Range, ws As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Shared Contact Pivot")
    For Each ws In Sheets
        If ws.Name Like "CPA*" Then
            For Each cel In ws.Range("B2", ws.Range("B" & ws.Rows.Count).End(xlUp))
                If cel.Value <> "" Then
                    desWS.Cells(Rows.Count, cel.Column).End(xlUp).Offset(1, 0).Value = cel.Value
                End If
            Next cel
        End If
    Application.ScreenUpdating = True
End Sub

[chrisellis250]

Getting a "For without next" error

[dangelor]

Possibly...

Sub CopyPivot()
    
    Dim cell As Range
    Dim i As Long
    
    i = Sheets("Shared Contact Pivot").Cells(Rows.Count, "B").End(xlUp).Row + 1
    For Each cell In Sheets("CPA 1").Range("B2:D" & Sheets("CPA 1").Cells(Rows.Count, "B").End(xlUp).Row)
        If cell.Value <> "" Then
            Sheets("Shared Contact Pivot").Range("B" & i).Resize(0, 3) = cell.Resize(0, 3)
            i = i + 1
        End If
        On Error Resume Next
        
    Next cell
    
    i = Sheets("Shared Contact Pivot").Cells(Rows.Count, "B").End(xlUp).Row + 1
    For Each cell In Sheets("CPA 2").Range("B2:D" & Sheets("CPA 2").Cells(Rows.Count, "B").End(xlUp).Row)
        If cell.Value <> "" Then
            Sheets("Shared Contact Pivot").Range("B" & i).Resize(0, 3) = cell.Resize(0, 3)
            i = i + 1
        End If
        On Error Resume Next
        
    Next cell

[chrisellis250]

I've added in a next, which gets it work but copies everything into one column - which is partly correct. Require data from columns C and D to be copied from the CPA worksheets into the Shared Contact Pivot worksheet.

[Mumps1]

Which macro are you referring to, the one I suggested or the one suggested by dangelor? Can you attach a copy of your file with the desired result in the "Shared Contact Pivot" sheet?

[chrisellis250]

I have attached a test copy of my workbook. The first 3 tabs are how they look in my actual workbook, with the yellow one showing the desired result.

As the data in any of the CPA tabs (There are 10 on my actual workbook) could be anything between 2 and 2000 rows worth of data, I need the code to be dynamic and copy from CPA 1 into the Shared Contact Pivot sheet, then copying CPA 2 underneath that and so on.

[chrisellis250]

Attached test workbook

[jindon]

Perhaps

Sub test()
    Dim ws As Worksheet
    For Each ws In Sheets(Array("CPA 1", "CPA 2"))
        ws.Range("b2", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 3).Copy _
        Sheets("Shared Contact Pivot").Range("b" & Rows.Count).End(xlUp)(2)
    Next
End Sub

[chrisellis250]

Thanks jindon, that worked perfectly! There are 10 CPA tabs, sometimes there will only be data in 2 or 3, so the others will be blank. When running this code it takes the headers from the blank CPA tabs and copies it into the Shared Contact Pivot. Is there a way to avoid this?

[jindon]

Try

Sub test()
    Dim ws As Worksheet, rng As Range, flg As Boolean
    Sheets("Shared Contact Pivot").Columns("b:d").Clear
    For Each ws In Worksheets
        If ws.Name Like "CPA #*" Then
            Set rng = ws.Range("b1", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 3)
            If rng.Rows.Count > 1 Then
                rng.Offset(IIf(flg, 1, 0)).Copy _
                Sheets("Shared Contact Pivot").Range("b" & Rows.Count).End(xlUp)(IIf(flg, 2, 1))
                flg = True
            End If
        End If
    Next
End Sub

[chrisellis250]

Perfect! Thank you

[jindon]

You are welcome and thanks for the rep.

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

[chrisellis250]

Hi Jindon,

I have added an extra column into Col C.

How would this now affect the code? Column B remains in the same place, but Columns C and D are now Columns D and E, so the code needs to change to affect those columns.

Many thanks,

[jindon]

You want to copy Col.B, Col.E & Col.E?

Sub test()
    Dim ws As Worksheet, rng As Range, flg As Boolean
    Sheets("Shared Contact Pivot").Columns("b:d").Clear
    For Each ws In Worksheets
        If ws.Name Like "CPA #*" Then
            Set rng = ws.Range("b" & IIf(flg, 2, 1), ws.Range("b" & Rows.Count).End(xlUp))
            If rng.Rows.Count > 1 Then
                Union(rng, rng.Columns("c:d")).Copy _
                Sheets("Shared Contact Pivot").Range("b" & Rows.Count).End(xlUp)(IIf(flg, 2, 1))
                flg = True
            End If
        End If
    Next
End Sub

[chrisellis250]

From the sheets entitled CPA 1, CPA 2 etc I want to copy:

Columns B:E from the second row down

INTO

B:E on the Shared Contact Pivot sheet into B2 initially and then CPA 2 into the next blank row and so on...

[jindon]

Then just change .Resize( ,3) to 4 in the first code.

Sub test()
    Dim ws As Worksheet
    For Each ws In Sheets(Array("CPA 1", "CPA 2"))
        ws.Range("b2", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 4).Copy _
        Sheets("Shared Contact Pivot").Range("b" & Rows.Count).End(xlUp)(2)
    Next
End Sub

[chrisellis250]

What about to loop through all of the sheets entitled CPA?

[jindon]

Ooops, it should be the 2nd one...

Sub test()
    Dim ws As Worksheet, rng As Range, flg As Boolean
    Sheets("Shared Contact Pivot").Columns("b:d").Clear
    For Each ws In Worksheets
        If ws.Name Like "CPA #*" Then
            Set rng = ws.Range("b1", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 4)
            If rng.Rows.Count > 1 Then
                rng.Offset(IIf(flg, 1, 0)).Copy _
                Sheets("Shared Contact Pivot").Range("b" & Rows.Count).End(xlUp)(IIf(flg, 2, 1))
                flg = True
            End If
        End If
    Next
End Sub