修改VBA合并工作簿代码 仅提取每个文件首个工作表

核心修改目标：仅合并每个待打开Excel文件的第一个工作表，跳过文件内其余工作表。

核心改动点 #

• 移除原代码中遍历待合并工作簿所有工作表的For Each循环，不再逐表复制
• 直接通过工作表索引Worksheets(1)定位每个待合并文件的第一个工作表执行复制操作，该方式比指定固定表名的兼容性更强，不会因个别文件表名意外改动报错
• 补充了几项运行稳定性优化：关闭弹窗、跳过当前主文件、支持更多Excel格式、打开文件不触发链接更新

修改后完整可运行代码 #

Option Explicit
' 使用前请修改下方文件夹路径为实际存放待合并文件的路径

Sub CombineFilesInSheetsFood()
     
    Dim Path            As String
    Dim FileName        As String
    Dim Wkb             As Workbook
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 请替换为你的实际文件夹路径
    Path = "C:\Users\c2200102\OneDrive - Coor Service Management\Desktop\Append\2022\"
    ' 匹配所有xls/xlsx/xlsm/xlsb格式的Excel文件，若仅需匹配老版本xls可改回"*.xls"
    FileName = Dir(Path & "*.xls*", vbNormal)
    
    Do Until FileName = ""
        ' 跳过存放合并结果的当前工作簿，避免自我打开报错
        If FileName <> ThisWorkbook.Name Then
            ' 打开文件时不更新外部链接，减少加载等待与弹窗
            Set Wkb = Workbooks.Open(FileName:=Path & FileName, UpdateLinks:=False)
            ' 仅复制打开文件的第一个工作表到当前工作簿的最后位置
            Wkb.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Wkb.Close SaveChanges:=False
        End If
        FileName = Dir()
    Loop
    
    ' 恢复Excel默认设置
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
     
End Sub

可选调整说明 #

如果你需要严格按照固定表名取工作表，可将代码中Wkb.Worksheets(1)替换为Wkb.Worksheets("你所有文件统一的首个工作表名称")即可，索引定位方式容错性更高，优先推荐使用。

• 若不需要合并xlsx等新版本格式，可将Dir匹配规则改回原有的"\*.xls"
• 合并后的工作表会默认保留原文件中第一个工作表的名称，如果需要重命名可以在复制行后加一行代码自定义表名

内容的提问来源于stack exchange，提问作者Christoffer Tuxen Rosing