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.