BlogCell.Docs | VBA Code - Combine Multiple Excel Files

See it in action

Introduction

Handling multiple Excel files manually can be time-consuming and prone to errors. If you often work with multiple Excel files and need a way to consolidate them into a single workbook automatically, this VBA script is the perfect solution.

In this post, you'll get a solution on how to use VBA to merge multiple Excel files from a selected folder into a single workbook, ensuring that each sheet is properly named and structured.

Why Use This VBA Macro?

Saves time by automating file merging
Ensures consistent sheet naming
Works on all Excel file formats (.xls, .xlsx, .xlsm)
Reduces manual errors and improves efficiency

How the VBA Code Works

This VBA script performs the following steps:

Prompts the user to select a folder containing Excel files.
Opens each Excel file in the selected folder.
Loops through all sheets in each file and copies their data to a new workbook.
Assigns appropriate names to each sheet while avoiding naming errors.
Saves the consolidated workbook to a location chosen by the user.

VBA Code

Sub M20_ExcelFiles()
    Dim wbDest As Workbook
    Dim wsDest As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim FldrPicker As FileDialog
    Dim srcWorkbook As Workbook
    Dim srcWorksheet As Worksheet
    Dim sheetCounter As Integer
    Dim newSheetName As String
 
    Application.ScreenUpdating = False
 
    ' Prompt user to select folder containing Excel files
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        myPath = .SelectedItems(1) & "\"
    End With
 
    ' Initialize the destination workbook
    Set wbDest = Workbooks.Add
    sheetCounter = 1 ' Initialize sheet counter
 
    ' Loop through all Excel files in the selected folder
    myFile = Dir(myPath & "*.xls*")
    Do While myFile <> ""
        ' Open each Excel file in the folder
        Set srcWorkbook = Workbooks.Open(myPath & myFile)
 
        ' Loop through each sheet in the opened workbook
        For Each srcWorksheet In srcWorkbook.Sheets
            ' Add a new sheet to the destination workbook
            Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count))
            ' Construct the new sheet name
            newSheetName = Left(myFile, Len(myFile) - 5) & "_" & srcWorksheet.Name ' Removes extension from file name
 
            ' Remove invalid characters and truncate if necessary
            newSheetName = Replace(newSheetName, ":", "_")
            newSheetName = Replace(newSheetName, "/", "_")
            newSheetName = Replace(newSheetName, "\", "_")
            newSheetName = Replace(newSheetName, "?", "_")
            newSheetName = Replace(newSheetName, "*", "_")
            newSheetName = Replace(newSheetName, "[", "_")
            newSheetName = Replace(newSheetName, "]", "_")
            If Len(newSheetName) > 31 Then
                newSheetName = Left(newSheetName, 31)
            End If
 
            ' Attempt to name the new sheet using the constructed name
            On Error GoTo NameError
            wsDest.Name = newSheetName
            On Error GoTo 0
            ' Copy data from source sheet to destination sheet
            srcWorksheet.UsedRange.Copy wsDest.Range("A1")
            GoTo NextSheet
 
NameError:
            ' If an error occurs, name the sheet with a default name and increment counter
            wsDest.Name = "Sheet Name (" & sheetCounter & ")"
            sheetCounter = sheetCounter + 1
            On Error GoTo 0
            ' Copy data from source sheet to destination sheet
            srcWorksheet.UsedRange.Copy wsDest.Range("A1")
 
NextSheet:
        Next srcWorksheet
 
        ' Close the opened workbook without saving changes
        srcWorkbook.Close False
 
        ' Move to the next file
        myFile = Dir
    Loop
 
    ' Save the combined workbook
    Dim savePath As Variant
    savePath = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save Combined Workbook As")
    If savePath <> False Then
        wbDest.SaveAs savePath
        wbDest.Close
    End If
 
    Application.ScreenUpdating = True
    MsgBox "Combining Excel files completed."
End Sub

How to Use the Macro

Open Microsoft Excel and press ALT + F11 to open the VBA Editor.
Click Insert > Module and paste the provided VBA code.
Run the macro by pressing F5.
Select the folder containing the Excel files when prompted.
Choose a location to save the combined workbook.
Once the process is completed, a message box will appear.

Conclusion

This VBA macro is an efficient way to automate Excel file consolidation, reducing errors and improving workflow efficiency. Try it out and see how much time you can save!

If you found this guide helpful, consider sharing it with your colleagues or subscribing for more Excel automation tips.

Sub M20_ExcelFiles() Dim wbDest As Workbook Dim wsDest As Worksheet Dim myPath As String Dim myFile As String Dim FldrPicker As FileDialog Dim srcWorkbook As Workbook Dim srcWorksheet As Worksheet Dim sheetCounter As Integer Dim newSheetName As String Application.ScreenUpdating = False ' Prompt user to select folder containing Excel files Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select a Folder" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub myPath = .SelectedItems(1) & "\" End With ' Initialize the destination workbook Set wbDest = Workbooks.Add sheetCounter = 1 ' Initialize sheet counter ' Loop through all Excel files in the selected folder myFile = Dir(myPath & "*.xls*") Do While myFile <> "" ' Open each Excel file in the folder Set srcWorkbook = Workbooks.Open(myPath & myFile) ' Loop through each sheet in the opened workbook For Each srcWorksheet In srcWorkbook.Sheets ' Add a new sheet to the destination workbook Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) ' Construct the new sheet name newSheetName = Left(myFile, Len(myFile) - 5) & "_" & srcWorksheet.Name ' Removes extension from file name ' Remove invalid characters and truncate if necessary newSheetName = Replace(newSheetName, ":", "_") newSheetName = Replace(newSheetName, "/", "_") newSheetName = Replace(newSheetName, "\", "_") newSheetName = Replace(newSheetName, "?", "_") newSheetName = Replace(newSheetName, "*", "_") newSheetName = Replace(newSheetName, "[", "_") newSheetName = Replace(newSheetName, "]", "_") If Len(newSheetName) > 31 Then newSheetName = Left(newSheetName, 31) End If ' Attempt to name the new sheet using the constructed name On Error GoTo NameError wsDest.Name = newSheetName On Error GoTo 0 ' Copy data from source sheet to destination sheet srcWorksheet.UsedRange.Copy wsDest.Range("A1") GoTo NextSheet NameError: ' If an error occurs, name the sheet with a default name and increment counter wsDest.Name = "Sheet Name (" & sheetCounter & ")" sheetCounter = sheetCounter + 1 On Error GoTo 0 ' Copy data from source sheet to destination sheet srcWorksheet.UsedRange.Copy wsDest.Range("A1") NextSheet: Next srcWorksheet ' Close the opened workbook without saving changes srcWorkbook.Close False ' Move to the next file myFile = Dir Loop ' Save the combined workbook Dim savePath As Variant savePath = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save Combined Workbook As") If savePath <> False Then wbDest.SaveAs savePath wbDest.Close End If Application.ScreenUpdating = True MsgBox "Combining Excel files completed." End Sub