Merging Multiple Worksheets into a Single Worksheet in Excel

Recently, we got a dozen of worksheets, which are some mappings that need to be loaded into Oracle Database, from clients intermittently. We need a macro to merge those worksheets together and save as a master csv file.

First, let's declare a public subroute and call it as PopulateSummary

Public Sub PopulateSummary()

Then, declare some variables that will be used later one

Dim ws As Worksheet
Dim SumWs As Worksheet
Dim no_of_ws As Integer
Dim i As Integer
Dim x As Integer
Dim y As Long
Dim LastCol As Integer
Dim CurR As Long
Dim hdrC As Integer

Since we don't know how many worksheets we have each time, we get the number dynamically and we will loop through each worksheet.

no_of_ws = ActiveWorkbook.Worksheets.count

For i = 1 To no_of_ws
    ' TODO
next i 

All the data will be merged to a new sheet called Summary. We need to make sure that the sheet exists beforehand.

Set SumWs = ActiveWorkbook.Worksheets("Summary")
If SumWs Is Nothing Then
    Debug.Print "Summary Worksheet not found"
Else
    ' TODO
End If

Inside the Else block, we loop through each cell and set the value to the Summary worksheet. Since our data starts from row 3, we set y to 3.

Set ws = ActiveWorkbook.Worksheets(i)
LastCol = 1
Do Until ws.Cells(1, LastCol).Value = ""
    LastCol = LastCol + 1
Loop

LastCol = LastCol - 1

y = 3
Do Until ws.Cells(y, LastCol).Value = ""
    x = 1
    hdrC = 1
    Do Until x > LastCol
        Do Until SumWs.Cells(1, hdrC).Value = ""
            If SumWs.Cells(1, hdrC).Value = ws.Cells(1, x).Value Then
                SumWs.Cells(CurR, hdrC) = ws.Cells(y, x).Value
                Exit Do
            End If
            hdrC = hdrC + 1
        Loop
        x = x + 1
    Loop
    y = y + 1
    CurR = CurR + 1
Loop

Here's the full subroute:

Public Sub PopulateSummary()
    Dim ws As Worksheet
    Dim SumWs As Worksheet
    Dim no_of_ws As Integer
    Dim i As Integer
    Dim x As Integer
    Dim y As Long
    Dim LastCol As Integer
    Dim CurR As Long
    Dim hdrC As Integer

    no_of_ws = ActiveWorkbook.Worksheets.count

    CurR = 2
    For i = 1 To no_of_ws
        Set SumWs = ActiveWorkbook.Worksheets("Summary")
        If SumWs Is Nothing Then
            Debug.Print "Summary Worksheet not found"
        Else
            Set ws = ActiveWorkbook.Worksheets(i)
            LastCol = 1
            Do Until ws.Cells(1, LastCol).Value = ""
                LastCol = LastCol + 1
            Loop

            LastCol = LastCol - 1

            y = 3
            Do Until ws.Cells(y, LastCol).Value = ""
                x = 1
                hdrC = 1
                Do Until x > LastCol
                    Do Until SumWs.Cells(1, hdrC).Value = ""
                        If SumWs.Cells(1, hdrC).Value = ws.Cells(1, x).Value Then
                            SumWs.Cells(CurR, hdrC) = ws.Cells(y, x).Value
                            Exit Do
                        End If
                        hdrC = hdrC + 1
                    Loop
                    x = x + 1
                Loop
                y = y + 1
                CurR = CurR + 1
            Loop
        End If
    Next i
End Sub

After running it, it is extremely slow when there are dozens of worksheets and it takes around 45 mintues to generate a merged worksheet. This is because we copy each cell one by one. If there are X worksheets with Y rows and Z columns, basically it will copy X_Y_Z times. The cost is pretty high.

Let's revamp the code.

Sometimes we turn on filtering for the selected cells. If the worksheet is actively filtering data, we make it visible.

If ws.FilterMode Then
    ws.ShowAllData
End If

Then, we can use the constants xlToRight and xlDown to find out the last column and the last row.

LastCol = ws.Cells(1, 1).End(xlToRight).Column
LastRow = ws.Cells(1, 1).End(xlDown).Row

Instead of copying each cell one by one

SumWs.Cells(CurR, hdrC) = ws.Cells(y, x).Value

We copy the whole row instead

ws.Range(ws.Cells(3, x).Address, ws.Cells(LastRow, x).Address).Copy
SumWs.Cells(TotalNoRow, hdrC).PasteSpecial xlPasteValues

Here's the full revamped subroute:

Public Sub PopulateSummary()
    Dim ws As Worksheet
    Dim SumWs As Worksheet
    Dim no_of_ws As Integer
    Dim i As Integer
    Dim x As Integer
    Dim y As Long
    Dim LastCol As Integer
    Dim LastRow As Long
    Dim CurR As Long
    Dim hdrC As Integer
    Dim TotalNoRow As Long

    no_of_ws = ActiveWorkbook.Worksheets.Count

    TotalNoRow = 2
    For i = 1 To no_of_ws
        Set ws = ActiveWorkbook.Worksheets(i)
        Set SumWs = ActiveWorkbook.Worksheets("Summary")
        If SumWs Is Nothing Then
            Debug.Print "Summary Worksheet not found"
        Else
            LastCol = 1
            If ws.FilterMode Then
                ws.ShowAllData
            End If
            LastCol = ws.Cells(1, 1).End(xlToRight).Column
            LastRow = ws.Cells(1, 1).End(xlDown).Row
            x = 1
            hdrC = 1
            If LastRow > 2 Then
                Do Until x > LastCol
                    Do Until SumWs.Cells(1, hdrC).Value = ""
                        If SumWs.Cells(1, hdrC).Value = ws.Cells(1, x).Value Then
                            ws.Range(ws.Cells(3, x).Address, ws.Cells(LastRow, x).Address).Copy
                            SumWs.Cells(TotalNoRow, hdrC).PasteSpecial xlPasteValues
                            Exit Do
                        End If
                        hdrC = hdrC + 1
                    Loop
                    x = x + 1
                Loop
                TotalNoRow = TotalNoRow + LastRow - 2
            End If
        End If
    Next i
End Sub

That's it. By running the macro with the same dataset, the data from dozens of worksheets can be merged into one single worksheet within seconds.