使用VBA合并多文件夹下同名Excel文件为单个工作簿的问题求助

原代码存在的核心问题 #

• 仅遍历每个子文件夹下的第一个xlsx文件，没有循环获取子文件夹内所有xlsx文件
• 目标写入对象错误，你需要的是为每个公司名称生成独立工作簿，而不是写入当前运行代码的工作簿（ThisWorkbook）
• 没有做工作表不存在、目标工作簿未创建的容错处理，也没有单独的输出路径配置

修正后完整代码 #

Sub MergeSameNameWorkbooks()
    Dim fPATH As String, outputPath As String
    Dim FSO As Object, FLD As Object, SubFLDRS As Object, SubFLD As Object
    Dim fileName As String, companyName As String
    Dim wbTarget As Workbook, wbData As Workbook
    Dim wsData As Worksheet, wsTarget As Worksheet
    Dim LR As Long, targetLR As Long
    Dim dict As Object ' 用字典记录已创建的公司工作簿
    
    ' 配置路径：主文件夹路径、输出文件夹路径
    fPATH = Sheets("Instructions").Range("C16") & "\Split spreadsheets\"
    outputPath = Sheets("Instructions").Range("C17") & "\" ' 请在Instructions表C17填写输出文件夹路径
    ' 自动创建不存在的输出文件夹
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(outputPath) Then FSO.CreateFolder outputPath
    ' 初始化字典存储公司名和对应工作簿对象
    Set dict = CreateObject("Scripting.Dictionary")
    
    Set FLD = FSO.GetFolder(fPATH)
    Set SubFLDRS = FLD.SubFolders
    
    ' 遍历所有子文件夹
    For Each SubFLD In SubFLDRS
        fileName = Dir(SubFLD.Path & "\*.xlsx", vbNormal)
        ' 循环处理当前子文件夹下所有xlsx文件
        Do While fileName <> ""
            companyName = fileName
            ' 打开数据源工作簿
            Set wbData = Workbooks.Open(SubFLD.Path & "\" & fileName)
            
            ' 检查是否已创建对应公司的目标工作簿
            If Not dict.Exists(companyName) Then
                ' 新建目标工作簿，先写入表头
                Set wbTarget = Workbooks.Add
                wbData.Sheets(1).Rows(1).Copy wbTarget.Sheets(1).Range("A1")
                wbTarget.SaveAs outputPath & companyName
                dict.Add companyName, wbTarget
            Else
                Set wbTarget = dict(companyName)
            End If
            
            ' 遍历数据源所有工作表
            For Each wsData In wbData.Worksheets
                ' 目标工作簿不存在对应工作表则新建
                On Error Resume Next
                Set wsTarget = wbTarget.Sheets(wsData.Name)
                If Err.Number <> 0 Then
                    Set wsTarget = wbTarget.Sheets.Add(After:=wbTarget.Sheets(wbTarget.Sheets.Count))
                    wsTarget.Name = wsData.Name
                    wsData.Rows(1).Copy wsTarget.Range("A1")
                End If
                On Error GoTo 0
                
                ' 复制数据（跳过表头避免重复）
                LR = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Row
                If LR >= 2 Then
                    targetLR = wsTarget.Range("A" & wsTarget.Rows.Count).End(xlUp).Row + 1
                    wsData.Range("A2:A" & LR).EntireRow.Copy
                    wsTarget.Range("A" & targetLR).PasteSpecial xlPasteValues
                End If
            Next wsData
            
            ' 关闭数据源、保存目标文件
            Application.CutCopyMode = False
            wbData.Close SaveChanges:=False
            wbTarget.Save
            
            ' 处理下一个文件
            fileName = Dir
        Loop
    Next SubFLD
    
    ' 关闭所有生成的目标工作簿
    Dim key As Variant
    For Each key In dict.Keys
        dict(key).Close SaveChanges:=True
    Next key
    
    ' 释放对象
    Set dict = Nothing
    Set FSO = Nothing
    MsgBox "合并完成，文件已保存至：" & outputPath, vbInformation
End Sub

使用说明 #

1. 先在Instructions工作表的C17单元格填写输出文件夹的完整路径
2. 代码默认所有同名工作簿的工作表结构、表头完全一致，自动跳过表头仅合并数据行
3. 如果所有工作簿只有1个工作表，可以删除遍历工作表的循环，直接读取第一个工作表即可提升运行效率

内容的提问来源于stack exchange，提问作者Joe_ft