VBA to Consolidate Multiple tans into one tab

[Henry1]

Hello
Hoping someone can help with my project. I need a VBA to combine multiple tabs into one tab called Consolidated. The tabs have the same layout but each tab has 5 sections that need to be added to the consolidated tab going down. See attached picture. There are 5 green sections going to the right.
I would like to take these sections from every tab and paste into the Consolidated tab right after each other. See the second picture.

Thanks for all your help on this one.

 

[Takae]

Hope this helps.

Sub sample()
Dim w As Worksheet
Dim LC As Long, LR As Long, i As Long

Application.ScreenUpdating = False

For Each w In Worksheets
    If w.Name <> "Consolidated" Then
        LC = w.Cells(1, Columns.Count).End(xlToLeft).Column
        LR = w.Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To LC Step 21
            w.Range(w.Cells(2, i), w.Cells(LR, i + 19)).Copy Sheets("Consolidated").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Next
    End If
Next
MsgBox "Done"

Application.ScreenUpdating = true

End Sub

 

[Henry1]

Thanks. Can you please add a code a the end to remove the rows that have zero balances?
This works as I wanted to though.

 

[Henry1]

i realized various tabs can have either 5 or 4 or 3 or 2 or 1 section of data. Would it be possible to adjust the code to only grab the data accordingly?

I really appreciate for all your help on this one!

 

[Takae]

Please try it.

Sub sample()
Dim w As Worksheet
Dim LC As Long, LR As Long, i As Long

Application.ScreenUpdating = False

For Each w In Worksheets
    If w.Name <> "Consolidated" Then
        LC = w.Cells(1, Columns.Count).End(xlToLeft).Column
        LR = w.Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To LC Step 21
            w.Range(w.Cells(2, i), w.Cells(LR, i + 19)).Copy Sheets("Consolidated").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Next
    End If
Next

With Sheets("Consolidated")
    .Range("A1").AutoFilter field:=20, Criteria1:=0
    If WorksheetFunction.Subtotal(3, .Range("A:A")) > 1 Then
        .Range("A1").CurrentRegion.Offset(1, 0).Resize(.Rows.Count - 1).EntireRow.Delete
    End If
    .Range("A1").AutoFilter
End With

MsgBox "Done"

Application.ScreenUpdating = True

End Sub

 

[Henry1]

The code stopped and displays this message:

 

[Takae]

I put a line in this code. If you got an error again, please click "Debug" and tell me colored line in the code.

Sub sample()
Dim w As Worksheet
Dim LC As Long, LR As Long, i As Long

Application.ScreenUpdating = False

For Each w In Worksheets
    If w.Name <> "Consolidated" Then
        LC = w.Cells(1, Columns.Count).End(xlToLeft).Column
        LR = w.Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To LC Step 21
            w.Range(w.Cells(2, i), w.Cells(LR, i + 19)).Copy Sheets("Consolidated").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Next
    End If
Next

With Sheets("Consolidated")
    .Range("A1").AutoFilter
    .Range("A1").AutoFilter field:=20, Criteria1:=0
    If WorksheetFunction.Subtotal(3, .Range("A:A")) > 1 Then
        .Range("A1").CurrentRegion.Offset(1, 0).Resize(.Rows.Count - 1).EntireRow.Delete
    End If
    .Range("A1").AutoFilter
End With

MsgBox "Done"

Application.ScreenUpdating = True

End Sub

 

[Henry1]

now the code worked but it deleted a bunch of data on the consolidated tab and the totals are not correct. on the consolidated tab there are blank spaces between sections of the data. I am guessing the code deleted the data after the first blank section.

 

[Takae]

Please try this.

Sub sample()
Dim w As Worksheet
Dim LC As Long, LR As Long, i As Long

Application.ScreenUpdating = False

With Sheets("Consolidated")
    If .FilterMode = True Then
        .Range("A1").AutoFilter
    End If
     .Range(.Range("A2"), .Range("A2").SpecialCells(xlLastCell)).ClearContents
End With

For Each w In Worksheets
    If w.Name <> "Consolidated" Then
        LC = w.Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LC Step 21
            LR = w.Cells(Rows.Count, i).End(xlUp).Row
            w.Range(w.Cells(2, i), w.Cells(LR, i + 19)).Copy Sheets("Consolidated").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Next
    End If
Next

With Sheets("Consolidated")
    .Range("A1").AutoFilter field:=20, Criteria1:=0
    If WorksheetFunction.Subtotal(3, .Range("A:A")) > 1 Then
        .Range("A1").CurrentRegion.Offset(1, 0).Resize(.Rows.Count - 1).EntireRow.Delete
    End If
    .Range("A1").AutoFilter
End With

MsgBox "Done"
Application.ScreenUpdating = True

End Sub