Code should create Master workbook in each folder separately in one go

Below code copy the multiple workbooks all sheets and paste these all sheet into new single workbook as sheets.

I have more than 10 folders which have multiple workbooks with sheets.

Currently what i am doing is, I open the new workbook and paste below code into the workbook then run it, Code ask me to select the folder then i select the folder then code runs and copy all workbooks sheets from particular folder and paste into the open workbooks as sheets then i save this workbook as master workbook into that particular folder.

I repeat this process more than 10 times because i run it for each folder separately.

All i want is when i run the code it should create Master workbook in each folder separately in one go.

Your help will be appreciated.

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
    For x = 1 To Sheets.Count
        If Worksheets(x).Range("A1").Value <> "" Then
            Sheets(x).Name = Worksheets(x).Range("A1").Value
        End If
        If Worksheets(x).Range("A1").Value <> "" Then
            Sheets(x).Range("A1").EntireRow.Delete
        End If
    Next
End Sub

Try this:

Dim wbkCurBook As Workbook
Dim countFolders As Long
Dim countFiles As Long
Dim countSheets As Long

Sub MergeExcelFiles()
    Dim fso As Object
    Dim fld As Object
    Dim sfl As Object
    Dim ParentFolder As String

    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            ParentFolder = .SelectedItems(1)
        Else
            Beep
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    countFolders = 0
    countFiles = 0
    countSheets = 0

    Set wbkCurBook = ActiveWorkbook
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set fld = fso.GetFolder(ParentFolder)
    For Each sfl In fld.SubFolders
        Call ProcessFolder(sfl)
    Next sfl

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

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub ProcessFolder(fld As Object)
    Dim fil As Object
    Dim wksCurSheet As Worksheet

    countFolders = countFolders + 1

    Set wbkCurBook = Workbooks.Add(Template:=xlWBATWorksheet)
    
    For Each fil In fld.Files
        If LCase(fil.Name) Like "*.xls*" Then
            Call ProcessFile(fil)
        End If
    Next fil

    Application.DisplayAlerts = False
    wbkCurBook.Worksheets(1).Delete
    Application.DisplayAlerts = True

    For Each wksCurSheet In wbkCurBook.Worksheets
        If wksCurSheet.Range("A1").Value <> "" Then
            wksCurSheet.Name = wksCurSheet.Range("A1").Value
            wksCurSheet.Range("A1").EntireRow.Delete
        End If
    Next wksCurSheet

    wbkCurBook.SaveAs Filename:=fld.Path & "\" & fld.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    wbkCurBook.Close SaveChanges:=False
End Sub

Sub ProcessFile(fil As Object)
    Dim wbkSrcBook As Workbook
    Dim wksSrcSheet As Worksheet

    countFiles = countFiles + 1

    Set wbkSrcBook = Workbooks.Open(Filename:=fil)
    For Each wksSrcSheet In wbkSrcBook.Worksheets
        countSheets = countSheets + 1
        wksSrcSheet.Copy After:=wbkCurBook.Worksheets(wbkCurBook.Worksheets.Count)
    Next
    wbkSrcBook.Close SaveChanges:=False
End Sub

6 Replies

HansVogelaar

MVP

Oct 06, 2021

ShazSh

Are all those folders subfolders of a single folder?

ShazSh

Brass Contributor

Oct 07, 2021

Yes all folders and subfolders are in single folder.

HansVogelaar

MVP

Oct 07, 2021

ShazSh

Try this the declarations at the beginning should be at the top of the module (after Option Explicit, if you have that).

Dim wbkCurBook As Workbook
Dim countFiles As Long
Dim countSheets As Long

Sub MergeExcelFiles()
    Dim fso As Object
    Dim fld As Object
    Dim ParentFolder As String
    Dim wksCurSheet As Worksheet

    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            ParentFolder = .SelectedItems(1)
        Else
            Beep
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    countFiles = 0
    countSheets = 0
    Set wbkCurBook = ActiveWorkbook
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set fld = fso.GetFolder(ParentFolder)
    Call ProcessFolder(fld)

    For Each wksCurSheet In wbkCurBook.Worksheets
        If wksCurSheet.Range("A1").Value <> "" Then
            wksCurSheet.Name = wksCurSheet.Range("A1").Value
            wksCurSheet.Range("A1").EntireRow.Delete
        End If
    Next wksCurSheet

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

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub ProcessFolder(fld As Object)
    Dim fil As Object
    Dim sfl As Object

    For Each fil In fld.Files
        If LCase(fil.Name) Like "*.xls*" Then
            Call ProcessFile(fil)
        End If
    Next fil

    For Each sfl In fld.SubFolders
        Call ProcessFolder(sfl)
    Next sfl
End Sub

Sub ProcessFile(fil As Object)
    Dim wbkSrcBook As Workbook
    Dim wksSrcSheet As Worksheet

    countFiles = countFiles + 1

    Set wbkSrcBook = Workbooks.Open(Filename:=fil)
    For Each wksSrcSheet In wbkSrcBook.Worksheets
        countSheets = countSheets + 1
        wksSrcSheet.Copy After:=wbkCurBook.Worksheets(wbkCurBook.Worksheets.Count)
    Next
    wbkSrcBook.Close SaveChanges:=False
End Sub

Forum Discussion

Code should create Master workbook in each folder separately in one go

6 Replies

Resources