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

Question

我有一个包含 100 个子文件夹的文件夹。每个子文件夹最多有 4 个 Excel 电子表格。我需要进入每个子文件夹并将 4 个工作簿合并为 1 个工作簿和 4 个工作表。

这是我开始的代码。但我必须手动打开每个文件夹。

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

我尝试更改 fnamelist

fnameList = path ""

但随后我收到“Ubound 预期数组”错误消息

我想修改它以自动进入文件夹并合并文件。

我试过了……我在终止线上遇到了一个自动化错误

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"

结束子

Answer 1

以下是您需要对当前代码进行更改的内容：

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