Friday, 12 October 2018

Merge different excel workbooks into a single workbook into different sheets 

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True) 
    If (vbBoolean <> VarType(fnameList)) Then 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Set wbkCurBook = ActiveWorkbook
            For Each fnameCurFile In fnameList
            countFiles = countFiles + 1
            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
            For Each wksCurSheet In wbkSrcBook.Sheets
 countSheets = countSheets + 1
 wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
 Next
   wbkSrcBook.Close SaveChanges:=False
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub
Posted by at
Labels:

1 comment:

  1. Anonymous4:10 pm, December 05, 2025

    Sub MergeExcelFiles()
    Dim fnameList As Variant
    Dim fnameCurFile As Variant
    Dim countFiles As Long, countSheets As Long
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
    Dim failures As String
    Dim startCalc As XlCalculation
    Dim wasScreenUpdating As Boolean
    Dim wasDisplayAlerts As Boolean

    On Error GoTo ErrHandler

    ' Save current app settings to restore later
    wasScreenUpdating = Application.ScreenUpdating
    startCalc = Application.Calculation
    wasDisplayAlerts = Application.DisplayAlerts

    fnameList = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
    Title:="Choose Excel files to merge", MultiSelect:=True)

    ' If user cancelled GetOpenFilename it returns False (a Boolean), otherwise an array of file paths
    If Not IsArray(fnameList) Then
    MsgBox "No files selected.", vbInformation, "Merge Excel files"
    Exit Sub
    End If

    countFiles = 0
    countSheets = 0
    failures = ""

    ' Improve performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    Set wbkCurBook = ThisWorkbook ' or ActiveWorkbook depending on what you want; ThisWorkbook is safer if macro workbook should be destination

    For Each fnameCurFile In fnameList
    ' Skip if user selected the workbook that already contains this macro (avoid copying a workbook into itself)
    If LCase(wbkCurBook.FullName) = LCase(CStr(fnameCurFile)) Then
    failures = failures & vbCrLf & "Skipped (same as destination): " & fnameCurFile
    GoTo NextFile
    End If

    On Error Resume Next
    Set wbkSrcBook = Workbooks.Open(Filename:=CStr(fnameCurFile), ReadOnly:=True)
    If Err.Number <> 0 Or wbkSrcBook Is Nothing Then
    failures = failures & vbCrLf & "Failed to open: " & fnameCurFile & " (Err " & Err.Number & ")"
    Err.Clear
    On Error GoTo ErrHandler
    GoTo NextFile
    End If
    On Error GoTo ErrHandler

    countFiles = countFiles + 1

    For Each wksCurSheet In wbkSrcBook.Worksheets
    On Error Resume Next
    wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
    If Err.Number <> 0 Then
    failures = failures & vbCrLf & "Failed to copy sheet '" & wksCurSheet.Name & "' from " & fnameCurFile & " (Err " & Err.Number & ")"
    Err.Clear
    Else
    countSheets = countSheets + 1
    End If
    On Error GoTo ErrHandler
    Next wksCurSheet

    wbkSrcBook.Close SaveChanges:=False

    NextFile:
    ' continue loop
    Next fnameCurFile

    ' Restore application settings
    Application.ScreenUpdating = wasScreenUpdating
    Application.Calculation = startCalc
    Application.DisplayAlerts = wasDisplayAlerts

    ' Summary
    Dim summary As String
    summary = "Processed " & countFiles & " file(s)." & vbCrLf & "Merged " & countSheets & " worksheet(s)."
    If Len(failures) > 0 Then
    summary = summary & vbCrLf & vbCrLf & "Problems encountered:" & failures
    End If

    MsgBox summary, vbInformation, "Merge Excel files"
    Exit Sub

    ErrHandler:
    ' Restore settings if an unexpected error occurs
    Application.ScreenUpdating = wasScreenUpdating
    Application.Calculation = startCalc
    Application.DisplayAlerts = wasDisplayAlerts
    MsgBox "Unexpected error " & Err.Number & ": " & Err.Description, vbCritical, "MergeExcelFiles"
    End Sub


    ReplyDelete

Subscribe to: Post Comments (Atom)