VBA to consolidate multiple sheets

dawnplt

New Member
Joined
Mar 16, 2021
Messages
3
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
  2. MacOS
Hi,

I am a newbie at VBA and need help with consolidating multiple sheets into one master sheet. This looks to be a common problem and I have tried searching the forums before deciding to create a post because I couldn't manage to edit the VBA code to fit.

So here's the gist: My headers span A1:AB4 across all sheets, which are named after months (from Jan to Dec). Obviously, the data in each month will vary so the rows in all sheets vary too, but all cells will be filled between columns A to AB. I would like to consolidate all these sheets into a master sheet "Summary". Below's the code I have so far, referenced from here, which I can't seem to get to work since I don't understand the second If loop (the copy and paste).

VBA Code:
Sub merge2()
Dim sh As Worksheet,  r As Long
Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "Summary"
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Summary" Then
                       If Application.CountA(Sheets("Summary").Range("A1:AB4").EntireRow) = 0 Then
                sh.Range("A1:AB4").Copy Sheets("Summary").Range("A1")
            End If
            sh.Range("A5", sh.Range("AB5").End(xlDown)).Copy
           Sheets("Summary").Cells(Rows.Count, 1).End(xlUp)(6).PasteSpecial xlPasteValues
        End If
    Next
End Sub

Would really appreciate any help, many thanks!
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
392
Office Version
  1. 2016
Platform
  1. Windows
Hello Dawnplt, welcome to Mr Excel forum.
Here is explanation of loop and second "If" statement.
When loop finds a sheet that is not "Summary" than code trying to check if summary table header exist.
If not, first it will be created, and then all other ranges will be copied below each other.
 

dawnplt

New Member
Joined
Mar 16, 2021
Messages
3
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
  2. MacOS
Hello Dawnplt, welcome to Mr Excel forum.
Here is explanation of loop and second "If" statement.
When loop finds a sheet that is not "Summary" than code trying to check if summary table header exist.
If not, first it will be created, and then all other ranges will be copied below each other.
Hi, thanks for the reply but what I'm having problem with is the copy paste part. The code I have currently (pasted above) copies the summary table headers but not the data in the other sheets. I can't figure out how to get it to work.
 

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
392
Office Version
  1. 2016
Platform
  1. Windows
Try with this code...
VBA Code:
Sub merge2()

    Dim sh As Worksheet, r As Long
    
    Application.ScreenUpdating = False
    Sheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "Summary"
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Summary" Then
            If Application.CountA(Sheets("Summary").Range("A1:AB4").EntireRow) = 0 Then
                sh.Range("A1:AB4").Copy Sheets("Summary").Range("A1")
            End If
            r = Split(Sheets("Summary").UsedRange.Address, "$")(4)
            sh.Range("A5:AB" & Split(sh.UsedRange.Address, "$")(4)).Copy
            Sheets("Summary").Cells(r + 1, 1).PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
        
End Sub
 

dawnplt

New Member
Joined
Mar 16, 2021
Messages
3
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
  2. MacOS
Try with this code...
VBA Code:
Sub merge2()

    Dim sh As Worksheet, r As Long
   
    Application.ScreenUpdating = False
    Sheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "Summary"
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Summary" Then
            If Application.CountA(Sheets("Summary").Range("A1:AB4").EntireRow) = 0 Then
                sh.Range("A1:AB4").Copy Sheets("Summary").Range("A1")
            End If
            r = Split(Sheets("Summary").UsedRange.Address, "$")(4)
            sh.Range("A5:AB" & Split(sh.UsedRange.Address, "$")(4)).Copy
            Sheets("Summary").Cells(r + 1, 1).PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
       
End Sub
Nice, it works now :) Thanks a lot!
 

Watch MrExcel Video

Forum statistics

Threads
1,130,337
Messages
5,641,571
Members
417,223
Latest member
jelena_

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top