VBA实现将批量Excel文件中的工作表合并成一个工作表

如同工作表的拆分操作，职场中时常涉及工作表的合并操作，如部门员工信息表、各销售部门的销售报表等。这些表格一般具有相同的结构、不同的数据行，且文件数多、数据量大等特点，虽然将这些数据文件合并操作相对比较简单，但工作重复、繁琐，并且往往是经常性的机械性的工作，这时，就要考虑用自动化的方式去完成。如果文件多且每个工作表中的数据量比较大，可以考虑采用Python+Pandas进行处理，这个当然需要具体的数据与计算要求；如果数据不算大（几千或上万条左右），那么可以直接用Excel结合VBA来解决。下面给出用VBA来实现选定的多个工作表的数据合并操作（多个工作表合并成一个工作表），然后就可以在此基础上进行计算及统计分析了。

假设有如下图所示的几个Excel工作簿文件，每个工作簿中包含一个工作表，并且每个工作表具有相同的标题行（抬头）：

4个示例Excel工作簿文件

下面我们用VBA宏来将选定的所有工作表合并为一张工作表。程序的基本思路是：（1）选择要合并的Excel工作簿（内含具有相同表式的工作表）；（2）新建一个空白Excel工作簿，包含一个空白的Excel工作表；（3）逐一访问选定的工作表，全选工作表中的行，然后将选定的数据复制到新建的Excel工作簿中。

按ALT+F11组合键进入到VBA编辑窗口，点击【插入\模块】菜单项，进入到通用模块编写窗口，然后输入如下图所示的VBA宏代码：

首先编写一个自定义函数SelectXlsxFiles，用于选择要合并的Excel工作簿文件。这里调用了VBA系统的GetOpenFileName选择文件对话框，参数FileFilter指定文件类型、MultiSelect:=True指定允许多选；选定的文件（包含完整的路径）存入到一个一维数组中，由函数名返回调用处。

通用子程序（宏）MergeWorksheets通过调用SelectXlsxFiles函数带回选定的Excel文件，然后通过For Each-Next循环遍历数组（访问每个Excel工作簿内的工作表），将工作表内的数据行复制到新建的空白工作表中，具体的代码含义见相应的注释。

代码编写完成后，返回到Excel工作表窗口，然后单击【开发工具】选项卡下的【代码】组内的【宏】命令，在弹出的【宏】窗口中选择MergeWorksheets宏，并单击“执行”，Excel将调用VBA宏自动执行相应的宏代码，自动完成工作表的合并操作。

具体的VBA代码文本如下：

Function SelectXlsxFiles() As Variant
   '选择文本文件，以数组形式返回选定的文件
    Dim strFolder As String
    Dim strFileFilter As String
    Dim varFiles As Variant
    Dim i As Integer
    ' 设置文件过滤器，只显示.xlsx文件
    strFileFilter = "Excel Files (*.xlsx),*.xlsx"
    ' 显示文件选择对话框，允许选择多个文件
    varFiles = Application.GetOpenFilename(FileFilter:=strFileFilter, MultiSelect:=True)
    ' 检查是否选择了文件
    If IsArray(varFiles) Then
       SelectXlsxFiles = varFiles
    Else
        ' 如果没有选择文件，则输出空值
       SelectTextFiles = "" '空值
    End If
End Function
Sub MergeWorksheets() '合并工作表
    Dim mainWorkbook As Workbook, mainSheet As Worksheet
    Dim sourceWorkbook As Workbook, sourceSheet As Worksheet
    Dim lastRow As Long, mergeRow As Long, fpath As Variant
    Dim arr As Variant
    arr = SelectXlsxFiles() '选择文件对话框
    If IsArray(arr) = False Then
      MsgBox "未选择要合并的Excel文件！", vbCritical + vbOKOnly, "提示"
      Exit Sub '未选择文件
    End If
    
    Application.ScreenUpdating = False '禁止屏幕刷新
    Application.StatusBar = "正在合并工作表，请稍候..."
    ' 创建合并后的工作簿
    Set mainWorkbook = Workbooks.Add
    Set mainSheet = mainWorkbook.Sheets(1)
    mainSheet.Name = "MergedData" ' 重命名合并后的工作表
 
    ' 合并每个工作簿中的数据
    mergeRow = 2 ' 假设标题行在第一行，数据从第二行开始
    
    For Each fpath In arr
        Workbooks.Open fpath
        Set sourceWorkbook = ActiveWorkbook
        Set sourceSheet = sourceWorkbook.Sheets(1)
 
        ' 复制数据到主工作簿
        sourceSheet.Rows("1:1").Copy Destination:=mainSheet.Rows("1:1") '复制标题行
        lastRow = sourceSheet.Range("A65535").End(xlUp).Row
        sourceSheet.Rows("2:" & lastRow).Copy Destination:=mainSheet.Range("A" & mergeRow)
 
        ' 关闭源工作簿，不保存
        sourceWorkbook.Close SaveChanges:=False
 
        ' 更新合并起始行
        mergeRow = mergeRow + lastRow - 1
    Next
    Application.ScreenUpdating = False
    Application.StatusBar = ""
    MsgBox "操作完成！", vbInformation + vbOKOnly, "提示"
End Sub

我是鉴水鱼老师，关注我，持续分享更多的Excel知识与操作技巧。