Loop through folders and merge excel files - 1 Excel File, Multiple Worksheets

Question

I have a folder with 100 subfolders. Each subfolder has up to 4 excel spreadsheets. I need to go into each subfolder and merge the 4 workbooks into 1 workbook with 4 worksheets.

This is the code I started with. But I have to manually open each folder.

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

I tried changing the fnamelist

fnameList = path ""

But then I get "Ubound expected array" error message

I would like to modify this to go into the folders automatically and merge files.

I tried this... i got an automation error on the kill line

Option Explicit
Sub MergeExcelFiles()

Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Dim ofile As File
Dim MyPath As String, MyFile As String, File As Workbook
Dim fnameList, fnameCurFile As Variant
Dim countFiles As Long, countSheets As Long
Dim wksCurSheet As Worksheet
Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
Dim RootFolderName As String

RootFolderName = Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .ButtonName = "Select Root Folder"
    If .Show <> -1 Then Exit Sub  ' if OK is pressed
    RootFolderName = .SelectedItems(1)
End With

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

countFiles = 0
countSheets = 0

Set fso = CreateObject("Scripting.FileSystemObject")
        Set f = fso.GetFolder(RootFolderName)
        For Each sf In f.SubFolders
            Set wbkCurBook = Workbooks.Add 'this comes here so we add a new workbook in every folder
            For Each ofile In sf.Files
                If fso.GetExtensionName(ofile.path) Like "xls*" Then
                countFiles = countFiles + 1
                fnameCurFile = ofile.path
                Debug.Print fnameCurFile
                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
                Kill wbkSrcBook.FullName 'this will delete the workbook that was being copied
                End If
            Next
            wbkCurBook.SaveAs sf.Name & "\" & "here the name of the workbook" 'this will save the file on the current folder.
            Set wbkCurBook = Nothing 'reset the varaible
        Next

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"

End Sub

Answer 1

Here is what you would need to change on the current code:

Option Explicit
Sub MergeExcelFiles()

    Dim fso As New FileSystemObject
    Dim f As Folder, sf As Folder
    Dim ofile As File
    Dim MyPath As String, MyFile As String, File As Workbook
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles As Long, countSheets As Long
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
    Dim RootFolderName As String

    RootFolderName = Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .ButtonName = "Select Root Folder"
        If .Show <> -1 Then Exit Sub  ' if OK is pressed
        RootFolderName = .SelectedItems(1)
    End With

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With

    countFiles = 0
    countSheets = 0

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(RootFolderName)
    For Each sf In f.SubFolders
        Set wbkCurBook = Workbooks.Add 'this comes here so we add a new workbook in every folder
        For Each ofile In sf.Files
            If fso.GetExtensionName(ofile.Path) Like "xls*" Then
            countFiles = countFiles + 1
            fnameCurFile = ofile.Path
            Debug.Print fnameCurFile
            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
            Kill wbkSrcBook.FullName 'this will delete the workbook that was being copied
            End If
        Next
        wbkCurBook.SaveAs sf.Name & "\" & "here the name of the workbook" 'this will save the file on the current folder.
        Set wbkCurBook = Nothing 'reset the varaible
    Next

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

    MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"

End Sub

Answer 2

May try something like (modify it to your requirement). Some declarations are not used (left out due to quick copy paste) may be deleted.

Option Explicit
Sub MergeExcelFiles()

    Dim fso As New FileSystemObject
    Dim f As Folder, sf As Folder
    Dim ofile As File
    Dim MyPath As String, MyFile As String, File As Workbook
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles As Long, countSheets As Long
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
    Dim RootFolderName As String

    RootFolderName = Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .ButtonName = "Select Root Folder"
        If .Show <> -1 Then Exit Sub  ' if OK is pressed
        RootFolderName = .SelectedItems(1)
    End With

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With

    countFiles = 0
    countSheets = 0

    Set wbkCurBook = ActiveWorkbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(RootFolderName)
    For Each sf In f.SubFolders
        For Each ofile In sf.Files
            If fso.GetExtensionName(ofile.Path) Like "xls*" Then
            countFiles = countFiles + 1
            fnameCurFile = ofile.Path
            Debug.Print fnameCurFile
            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
            End If
        Next
    Next

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

    MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"

End Sub