Merges data from multiple Excel files in a selected folder into one worksheet.

merge-excel-worksheets.bas

Attribute VB_Name = "Module1"
Public Function SelectFolder(Optional Title As String, Optional TopFolder As String) As String
    ' Creates a folder browser dialog to select a folder.
    ' Title - Title of the folder browser.
    ' TopFolder - Initial directory to display.
    
    Dim objShell As New Shell32.Shell
    Dim objFolder As Shell32.Folder

    ' If 16384 is used instead of 1, files are also displayed in the dialog.
    Set objFolder = objShell.BrowseForFolder(0, Title, 1, TopFolder)
    If Not objFolder Is Nothing Then
        ' Returns the path of the selected folder
        SelectFolder = objFolder.Items.Item.Path
    End If
End Function

Function FindLastCellColRow(choice As Integer, rng As Range)
    ' Finds the last cell, row, or column used in a specified range.
    ' choice - 1 for last row, 2 for last column, 3 for last cell.
    
    Dim lrw As Long
    Dim lcol As Integer

    Select Case choice
    Case 1 ' Find last row
        On Error Resume Next
        FindLastCellColRow = rng.Find(What:="*", _
                          after:=rng.Cells(1), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        On Error GoTo 0

    Case 2 ' Find last column
        On Error Resume Next
        FindLastCellColRow = rng.Find(What:="*", _
                          after:=rng.Cells(1), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
        On Error GoTo 0

    Case 3 ' Find last cell (based on both row and column)
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                    after:=rng.Cells(1), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        lcol = rng.Find(What:="*", _
                     after:=rng.Cells(1), _
                     Lookat:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByColumns, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        FindLastCellColRow = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            FindLastCellColRow = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
    End Select
End Function

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range, rngA2 As Range, rngA1 As Range
    Dim rnum As Long, CalcMode As Long
    Dim FirstCell As String

    ' Prompt user to select the folder containing files to be merged
    MyPath = SelectFolder("Select containing folder", "")
    If Len(MyPath) Then
        MsgBox "Selected folder is: " & MyPath
    Else
        MsgBox "Cancel was pressed"
    End If
    
    ' Ensure the folder path ends with a backslash
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' Retrieve the first Excel file in the folder
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Populate MyFiles array with all Excel file names in the folder
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Configure application settings for performance
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Create a new workbook with one worksheet to store merged data
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1 ' Row number tracker for merged worksheet

    ' Initialize FirstCell to A1 (to include headers in the first file)
    FirstCell = "A1"
    
    ' Loop through all files in MyFiles array
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) ' Open each workbook
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next
                With mybook.Worksheets(1) ' Only processes the first sheet in each workbook
                    ' Define the source range to copy
                    Set sourceRange = .Range(FirstCell & ":" & FindLastCellColRow(3, .Cells))
                    ' Test if the row of the last cell is equal to or greater than the row of the first cell
                    If FindLastCellColRow(1, .Cells) < .Range(FirstCell).Row Then
                        Set sourceRange = Nothing
                    End If
                End With
                
                ' Check for errors or incompatible ranges
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns, then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count

                    ' Ensure the destination worksheet has enough rows
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        ' Copy filename in column A
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With

                        ' Set the destination range
                        Set destrange = BaseWks.Range("B" & rnum)

                        ' Copy values and formats from source to destination
                        sourceRange.Copy
                        With BaseWks.Cells(rnum, "B")
                           .PasteSpecial xlPasteValues
                           .PasteSpecial xlPasteFormats
                           Application.CutCopyMode = False
                        End With

                        ' Update row number tracker
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

            ' Set FirstCell to A2 for subsequent files (to exclude headers)
            FirstCell = "A2"
        Next FNum
        
        ' Rename and format cell A1
        BaseWks.Cells(1, 2).Copy BaseWks.Cells(1, 1)
        BaseWks.Cells(1, 1).Value = "Source filename"
        
        ' Auto-fit columns for readability
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore application settings
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub