VBA – Macro to Combine (Append) Sheets

Many times, we need to combine worksheets together. Below is a Macro to do this.

You just need to change the parameter in "Change Parameters in this Section".

1. In case of many sheets, it will merge all sheets.
2. If you don't want to merge all sheets but few sheets, just create two sheets named "Start" and "Finish" and move all sheets between these Start and Finish. The macro will merge all sheets between Start and Finish.

1. Make a backup of your workbook.
2. Open your workbook and ALT+F11
3. Locate your Workbook name in Project Explorer Window
4. Right click on your workbook name > Insert > Module
5. Go back to your Workbook and ALT+F8 to display Macro Window
6. Run your Macro from here
7. Delete you Macro if the Macro was needed to be run only once.
8. Otherwise save your file as .xlsm if you intend to reuse Macro again.

A workbook containing below code can be downloaded from CombineSheets

Sub MergeSheets()
    
    Dim HasHeaderRow As String * 1, SameWorkbook As String * 1
    Dim OPSheet As String
    Dim ToDir As String, FileName As String
    
 '******** Change Parameters in this section ****************
    'Set the values for HasHeaderRow and ToDir
    HasHeaderRow = "Y"
    SameWorkbook = "Y"
    OPSheet = "Result"
    
    'Set the Save Directory and File Name if result is not wanted in the same workbook
    If SameWorkbook <> "Y" Then
        ToDir = "C:\Junk\"
        FileName = "Combined"
    End If
'***************************************************************
    
    Call Merge(HasHeaderRow = "Y", SameWorkbook = "Y", OPSheet, ToDir, FileName)

End Sub

Sub Merge(ByVal HasHeaderRow As Boolean, ByVal SameWorkbook As Boolean, ByVal OPSheet As String, _
            ByVal ToDir As String, ByVal FileName As String)
    
    Dim i As Long, StartIndex As Long
    Dim ToPath As String
    Dim TWk As Workbook, SWk As Workbook
    Dim Ws As Worksheet
    Dim Rng As Range, NewCell As Range
    Dim StartExists As Boolean, x As Boolean
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set SWk = ActiveWorkbook
    
    'Check for the existence of directory if output is needed in a different directory
    If SameWorkbook = False Then
        If Right(ToDir, 1) <> "\" Then
            ToDir = ToDir & "\"
        End If
        On Error Resume Next
            If Dir(ToDir) = "" Then
                MsgBox ToDir & " does not exist"
                Exit Sub
            End If
        On Error GoTo 0
        
        'Set the file name which is FileName_Current Date_Current Time
        ToPath = ToDir & FileName & "_" & Format(Date, "mmddyy") & "_" & Format(Time, "hhmmss")
        
        'Create the workbook where data needs to be copied
        Set TWk = Workbooks.Add
        Else
        Set TWk = SWk
    End If
    
    'Create OPSheet.
    On Error Resume Next
        Set Ws = TWk.Worksheets(OPSheet)
        If Err.Number <> 0 Then
            TWk.Worksheets.Add(Before:=TWk.Worksheets(1)).Name = OPSheet
        End If
    On Error GoTo 0
    'If OPSheet is existing, just clear it
    TWk.Worksheets(OPSheet).Cells.Clear
    
    'Check for existence of Start Sheet - If Start Sheet is there
    'then combine from Start otherwise combine from 1st sheet itself
    On Error Resume Next
    With SWk
        Set Ws = .Worksheets("Start")
            If Err.Number = 0 Then
                StartExists = True
                StartIndex = .Worksheets("Start").Index + 1
                Else
                'If within the same workbook, then we need to increase the index by 1 as first sheet is Result sheet now
                If SameWorkbook = True Then
                    StartIndex = 2
                    Else
                    StartIndex = 1
                End If
            End If
        On Error GoTo 0
        
        'Set the starting cell in first sheet of Target Workbook
        Set NewCell = TWk.Worksheets(OPSheet).Range("A1")
        
        For i = StartIndex To .Worksheets.Count
            'If there is a sheet names Finish, then stop combining
            If .Worksheets(i).Name = "Finish" Then Exit For
                If .Worksheets(i).Name <> "Result" Then
                'Check if the sheet is blank or not - If blank, no need to process
                If WorksheetFunction.CountA(.Worksheets(i).Cells) - WorksheetFunction.CountA(.Worksheets(i).Rows(1)) <> 0 Then
                    'x is a parameter which is set after first processing. In first processing, Header Row is not important
                    'But starting second processing, Header Row is Important. If Header Row is Y, then we should not select
                    'first row. Hence, x is set to True in this case.
                    If x = False Then
                        Set Rng = .Worksheets(i).UsedRange
                        Else
                        Set Rng = .Worksheets(i).UsedRange.Offset(1, 0)
                        Set Rng = Rng.Resize(Rng.Rows.Count - 1)
                    End If
                    'Copy the Range to Target Workbook
                    Rng.Copy NewCell
                    'Set the new cell to Next row of Column A in Target Workbook
                    Set NewCell = TWk.Worksheets(OPSheet).Cells(TWk.Worksheets(OPSheet).UsedRange.Rows.Count + 1, "A")
                    'Set NewCell = TWk.Worksheets(OPSheet).Cells(Rng(Rng.Cells.Count).Row + 1, "A")
                    If HasHeaderRow = True Then
                        x = True
                    End If
                End If
            End If
        Next i
    End With
    
    If SameWorkbook = False Then
        TWk.SaveAs FileName:=ToPath, FileFormat:=51
    End If
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.CutCopyMode = False

End Sub