如何使用VBA从多个Excel工作表末尾提取数据并汇总到合并文件

前置准备 #

• 将36个待提取的独立Excel文件统一放到同一个空白文件夹中，不要和合并文件混放
• 提前梳理好匹配规则：每个独立文件对应4个合并文件中的哪一个、以及该合并文件下的哪个目标工作表，后续直接在代码里修改规则即可，不需要逐一写文件打开逻辑

完整可运行代码 #

Sub 批量提取数据到合并文件()
    Dim folderPath As String
    Dim ifFileName As String
    Dim wbIF As Workbook, wbCF As Workbook
    Dim wsTarget As Worksheet
    Dim lastRowIF As Long, lastRowCF As Long
    Dim copyRange As Range
    
    ' 选择独立文件所在文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择存放36个独立Excel文件的文件夹"
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1) & "\"
    End With
    
    ' 关闭屏幕更新和警告，提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 遍历文件夹下所有Excel文件
    ifFileName = Dir(folderPath & "*.xls*")
    Do While ifFileName <> ""
        ' 跳过临时文件
        If Left(ifFileName, 2) <> "~$" Then
            ' 打开独立文件
            Set wbIF = Workbooks.Open(folderPath & ifFileName)
            
            ' --------------------------
            ' 此处修改你的匹配规则，示例：按独立文件名关键词匹配对应合并文件和工作表
            ' 你可以根据自己的实际规则增删Case分支
            Select Case True
                Case InStr(ifFileName, "北区") > 0
                    ' 匹配到北区数据，打开对应合并文件，指定目标工作表
                    Set wbCF = Workbooks.Open("C:\你的合并文件路径\北区合并文件.xlsx")
                    Set wsTarget = wbCF.Sheets("北区每日数据")
                Case InStr(ifFileName, "南区") > 0
                    Set wbCF = Workbooks.Open("C:\你的合并文件路径\南区合并文件.xlsx")
                    Set wsTarget = wbCF.Sheets("南区每日数据")
                Case InStr(ifFileName, "东区") > 0
                    Set wbCF = Workbooks.Open("C:\你的合并文件路径\东区合并文件.xlsx")
                    Set wsTarget = wbCF.Sheets("东区每日数据")
                Case InStr(ifFileName, "西区") > 0
                    Set wbCF = Workbooks.Open("C:\你的合并文件路径\西区合并文件.xlsx")
                    Set wsTarget = wbCF.Sheets("西区每日数据")
                ' 其他匹配规则自行添加
                Case Else
                    ' 未匹配到规则的文件直接跳过
                    wbIF.Close SaveChanges:=False
                    ifFileName = Dir
                    GoTo continueLoop
            End Select
            ' --------------------------
            
            ' 获取独立文件数据的最后一行（默认取第一个工作表，需要改表名的话把Sheets(1)改成Sheets("你的表名")）
            lastRowIF = wbIF.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            ' 只复制第2行到最后一行的有效数据
            If lastRowIF >= 2 Then
                Set copyRange = wbIF.Sheets(1).Rows("2:" & lastRowIF)
                ' 获取目标工作表的最后一个空行
                lastRowCF = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
                ' 直接赋值粘贴，比剪贴板更快更稳定
                copyRange.Copy wsTarget.Rows(lastRowCF)
            End If
            
            ' 保存并关闭合并文件
            wbCF.Close SaveChanges:=True
            ' 关闭独立文件不保存
            wbIF.Close SaveChanges:=False
        End If
continueLoop:
        ifFileName = Dir
    Loop
    
    ' 恢复设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "所有数据提取完成！"
End Sub

使用步骤 #

• 打开任意Excel文件，按Alt+F11调出VBA编辑器
• 在左侧工程资源管理器右键点击当前文件，选择「插入」→「模块」
• 将上述代码粘贴到模块编辑区，修改代码中匹配规则部分的合并文件路径、工作表名为你自己的实际内容
• 按F5运行，在弹出的对话框中选择存放36个独立文件的文件夹即可自动完成全部提取操作

注意事项 #

• 运行前请备份所有原始文件，避免误操作导致数据丢失
• 请确保独立文件和目标工作表的列顺序完全一致，否则会出现数据错位
• 如果独立文件需要取指定工作表的数据，把代码中的wbIF.Sheets(1)修改为wbIF.Sheets("你要取的表名")即可
• 如果需要处理.csv格式的文件，把Dir(folderPath & "*.xls*")修改为Dir(folderPath & "*.csv")即可

内容的提问来源于stack exchange，提问作者Dan Andrei Sica