Combine the Workbooks in a Folder

The following procedure creates a new workbook containing one worksheet in which to combine the data. Then it copies the data from "Sheet1" of each workbook in the specified folder to the worksheet in the newly created workbook.

Note that it's assumed that the source data contains column headers in the first row. Also, the workbook containing this code can be located in the same folder as the other workbooks.

'Force the explicit declaration of variables
Option Explicit

Sub CombineWorkbooks()

    'Declare the variables
    Dim arrFiles() As String
    Dim strPath As String
    Dim strFile As String
    Dim wkbDest As Workbook
    Dim wksDest As Worksheet
    Dim wkbSource As Workbook
    Dim wksSource As Worksheet
    Dim SourceRange As Range
    Dim SourceRowCount As Long
    Dim NextRow As Long
    Dim LastRow As Long
    Dim LastCol As Long
    Dim FileCnt As Long
    Dim Cnt As Long
    Dim i As Long
    Dim CalcMode As Long
  
    'Specify the path to the folder containing the files
    strPath = "C:\Users\Domenic\Documents\"
  
    'Make sure that the path ends in a backslash
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  
    'Check if the path exists
    If Len(Dir(strPath, vbDirectory)) = 0 Then
        MsgBox "The path to your folder does not exist.  Please check" & vbCrLf & _
            "the path, and try again!", vbExclamation
        Exit Sub
    End If
    
    'Get the first Excel file from the folder
    strFile = Dir(strPath & "*.xls", vbNormal)
  
    'Fill the array with a list of Excel files in the folder...
    FileCnt = 0
    Do While Len(strFile) > 0
        '...except this workbook, in case it's in the same folder
        If strFile <> ThisWorkbook.Name Then
            FileCnt = FileCnt + 1
            ReDim Preserve arrFiles(1 To FileCnt)
            arrFiles(FileCnt) = strFile
        End If
        'Get the next Excel file from the folder
        strFile = Dir
    Loop
    
    'If no Excel files were found, exit the sub
    If FileCnt = 0 Then
        MsgBox "No Excel files were found...", vbExclamation
        Exit Sub
    End If
  
    'Change the settings for Calculation, DisplayAlerts, EnableEvents,
    'and ScreenUpdating

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With
  
    'Create a new workbook with one worksheet
    Set wkbDest = Workbooks.Add(xlWBATWorksheet)
    
    'Set the destination worksheet
    Set wksDest = wkbDest.Worksheets(1)
    
    'Specify the row in which to start copying the data
    NextRow = 1
  
    'Loop through each Excel file in the array...
    Cnt = 0
    For i = LBound(arrFiles) To UBound(arrFiles)
    
        'Open the current file
        Set wkbSource = Workbooks.Open(strPath & arrFiles(i))
        
        'Set the source worksheet
        On Error Resume Next
        Set wksSource = wkbSource.Worksheets("Sheet1")
        On Error GoTo 0
        
        'Check if the worksheet exists
        If Not wksSource Is Nothing Then
        
            With wksSource
            
                'Find the last used row in Column A
                LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                
                'Find the last used column in Row 1
                LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
                'Check if the worksheet contains data beyond column headers
                If LastRow > 1 Then
                
                    'Increase the count by one
                    Cnt = Cnt + 1
                    
                    'Set the source range...
                    If Cnt = 1 Then
                        '...including the column headers
                        Set SourceRange = .Range("A1", .Cells(LastRow, LastCol))
                    Else
                        '...excluding the column headers
                        Set SourceRange = .Range("A2", .Cells(LastRow, LastCol))
                    End If
                
                    'Count the number of rows in the source range
                    SourceRowCount = SourceRange.Rows.Count
                    
                    'If there aren't enough rows in the destination sheet,
                    'exit the sub

                    If NextRow + SourceRowCount - 1 > wksDest.Rows.Count Then
                        MsgBox "Sorry, there are not enough rows available " & _
                            "in the destination worksheet!", vbExclamation
                        wkbSource.Close savechanges:=False
                        GoTo ExitSub
                    End If
                
                    'Copy the data from the source range to the destination sheet
                    SourceRange.Copy
                    With wksDest.Cells(NextRow, "A")
                        .PasteSpecial Paste:=xlPasteValues
                        .PasteSpecial Paste:=xlPasteFormats
                    End With
                
                    'Determine the next available row
                    NextRow = NextRow + SourceRowCount
                
                End If
                
            End With
            
            'Set the object variable for the source worksheet to Nothing
            Set wksSource = Nothing
            
        End If
        
        'Close the current file, without saving it
        wkbSource.Close savechanges:=False
            
    Next i
    
    'Check if any data has been copied to the destination worksheet
    If Cnt > 0 Then
    
        'Select the first cell and change the width of the columns to
        'achieve the best fit

        With wksDest
            .Cells(1).Select
            .Columns.AutoFit
        End With
        
    Else
    
        'Display message box advising user that no data was available to be copied
        MsgBox "No data was available to be copied...", vbInformation
        
        'Close the destination workbook, without saving it
        wkbDest.Close savechanges:=False
        
    End If
  
ExitSub:

    'Restore the settings for Calculation, DisplayAlerts, EnableEvents,
    'and ScreenUpdating

    With Application
        .Calculation = CalcMode
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With
  
End Sub

Tip  A worksheet can be referenced by index number instead of a sheet name. Therefore, to refer to the first sheet of each workbook instead of "Sheet1", replace...

Set wksSource = wkbSource.Worksheets("Sheet1")

with

Set wksSource = wkbSource.Worksheets(1)

Where to Put the Code

  1. Open the workbook in which to store the code.
  2. Open the Visual Basic Editor (Alt+F11).
  3. Insert a standard module (Insert > Module).
  4. Copy/paste the above code into the module.
  5. Return to Microsoft Excel (Alt+Q).
  6. Save the workbook.

How to Use the Macro

  1. Display the Macro dialog box (Alt+F8).
  2. Click/select the macro called "CombineWorkbooks".
  3. Click/select "Run".

Sample Workbook: Download