如何用VBA合并同文件夹下所有工作簿指定工作表的数据？

当然可以通过VBA实现这个需求，下面是具体的实现方案：

核心思路 #

• 选择目标文件夹，遍历其中所有Excel工作簿
• 打开每个工作簿，定位到指定名称的工作表
• 将该工作表的数据（跳过重复表头）复制到汇总工作簿的指定工作表中
• 关闭源工作簿，完成遍历后恢复Excel默认设置

完整VBA代码 #

Sub MergeSameNameSheets()
    Dim folderPath As String
    Dim fileName As String
    Dim sourceWB As Workbook
    Dim targetWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim sheetNameToMerge As String
    
    ' 设置要合并的工作表名称
    sheetNameToMerge = "Sheet1" ' 替换成你的目标工作表名称
    
    ' 创建新工作簿作为汇总表
    Set targetWB = Workbooks.Add
    Set targetWS = targetWB.Sheets(1)
    targetWS.Name = "汇总数据"
    
    ' 选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择要合并的工作簿所在文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹，程序退出"
            Exit Sub
        End If
    End With
    
    ' 关闭屏幕更新、自动计算，提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 遍历文件夹中的所有Excel文件
    fileName = Dir(folderPath & "*.xlsx")
    Do While fileName <> ""
        ' 跳过汇总工作簿本身
        If fileName <> targetWB.Name Then
            Set sourceWB = Workbooks.Open(folderPath & fileName)
            On Error Resume Next
            Set sourceWS = sourceWB.Sheets(sheetNameToMerge)
            On Error GoTo 0
            
            If Not sourceWS Is Nothing Then
                ' 获取源表最后一行和目标表最后一行
                lastRowSource = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
                lastRowTarget = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row
                
                ' 复制数据：第一次复制包含表头，之后只复制数据行
                If lastRowTarget = 1 Then
                    sourceWS.Rows("1:" & lastRowSource).Copy targetWS.Range("A1")
                Else
                    sourceWS.Rows("2:" & lastRowSource).Copy targetWS.Range("A" & lastRowTarget + 1)
                End If
            Else
                MsgBox fileName & "中未找到名为" & sheetNameToMerge & "的工作表，已跳过该文件"
            End If
            
            ' 关闭源工作簿，不保存修改
            sourceWB.Close SaveChanges:=False
            Set sourceWS = Nothing
            Set sourceWB = Nothing
        End If
        fileName = Dir()
    Loop
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "数据合并完成！"
End Sub

关键说明 #

• 修改工作表名称：将代码中的sheetNameToMerge = "Sheet1"替换为你实际要合并的工作表名称
• 文件格式适配：代码默认处理.xlsx文件，若需要处理.xls或.xlsm，修改Dir(folderPath & "*.xlsx")中的后缀即可
• 表头去重：仅在第一次复制时包含表头，后续只复制数据行，避免重复
• 错误兼容：如果某个工作簿中没有指定名称的工作表，会弹出提示并跳过该文件
• 性能优化：关闭屏幕更新和自动计算可以大幅提升合并大量文件时的运行速度

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