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. Currentl...

Macros and VBA

HansVogelaar

Oct 07, 2021

ShazSh

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

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

ShazSh

Brass Contributor

Oct 07, 2021

Sir i think i could not elaborate.
I want that if I have 1 folder which name is "Main Data" then there are 5 subfolders in it. which names are Folder 1,2,3,4 and 5 and there are 5 to 10 workbooks in each folder.

What i want is if i run the code and select the folder "Main Data" then code will be initiated on Folder "1" after completing the processing in Folder "1" code should create a "Master workbook" in that Folder for all the workbooks which are available in the Particular Folder.

Then same goes to other folders. Each folder should have their own "Master Workbook"

Current code created the single "Master Workbook" for all folders.

HansVogelaar

MVP

Oct 07, 2021

ShazSh

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

Forum Discussion

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

Resources