使用VBA合并多个Excel工作簿(3种形式)

使用 VBA 合并多个 Excel 工作簿 例如 需要将多个 Excel 工作簿中的工作表合并到一个工作簿 这里假设需要合并的工作 簿在 D 示例 数据记录 文件夹中 含有两个工作簿 test1 xls test2 xls 当然 可以不 限于两个 在 test1 xls 工作簿中含有三张工作表 在 test2 xls 工作簿中含有两张工作表 现在使用一段 VBA 代码合并这两个工作簿到一个新工作簿中 合并到新工作簿中的工作 表分别以原工作簿名加索引值命名 代码如下 Sub CombineWorkbooks Dim strFileName As String Dim wb As Workbook Dim wsAs Object 包含工作簿的文件夹 可根据实际修改 ConststrFileDir As String D 示例 数据记录 Application ScreenUpdating False Set wb Workbooks Add xlWorksheet strFileName Dir strFileDir xls Do While strFileNamevbNullString Dim wbOrig As Workbook Set wbOrig Workbooks Open Filename strFileDir strFileName ReadOnly True strFileName Left Left strFileName Len strFileName 4 29 For Each wsInwbOrig Sheets ws Copy After wb Sheets wb Sheets Count If wbOrig Sheets Count 1 Then wb Sheets wb Sheets Count Name strFileName ws Index Else wb Sheets wb Sheets Count Name strFileName End If Next wbOrig CloseSaveChanges False strFileName Dir Loop Application DisplayAlerts False wb Sheets 1 Delete Application DisplayAlerts True Application ScreenUpdating True Set wb Nothing End Sub 2 下面是合并多个 Excel 工作簿的另一种情形 也是 Excel VBA 实战技巧精粹 中所介绍的方法 即合并汇总 有四个工作簿 分别为 汇总工作簿 xls 一月 xls 二月 xls 三月 xls 其中一月 xls 二 月 xls 三月 xls 均只含有一张工作表且工作表中的数据均自单元格 A1 开始 现在要求将 它们合并至 汇总工作簿 xls 中 在 汇总工作簿 xls 中打开 VBE 并输入下列代码 Sub ConsolidateWorkbook Dim RangeArray As String Dim bk As Workbook Dim sht As Worksheet Dim WbCountAs Integer WbCount Workbooks Count ReDimRangeArray 1 To WbCount 1 For Each bk In Workbooks 在所有工作簿中循环 If Not bk Is ThisWorkbook Then 非代码所在工作簿 Set sht bk Worksheets 1 引用工作簿的第一个工作表 i i 1 RangeArray i bk Name sht Name sht Range A1 CurrentRegion Address ReferenceStyle xlR1C1 End If Next Worksheets 1 Range A1 Consolidate RangeArray xlSum True True End Sub 3 下面是汇总多个工作簿的又一种情形 也是一名网友提出的问题 在同一文件夹中有多 个工作簿 其中有一个用于汇总的工作簿 要求将除该汇总工作簿外的其它工作簿中的第 一张工作表的数据汇总到该汇总工作簿中 代码如下 Sub UnionWorksheets Application ScreenUpdating False Dim lj As String Dim dirname As String Dim nm As String lj ActiveWorkbook Path nm ActiveWorkbook Name dirname Dir lj xls Cells Clear Do Whiledirname If dirname nm Then Workbooks Open Filename lj dirname Workbooks nm Activate 复制新打开工作簿的第一个工作表的已用区域到当前工作表 Workbooks dirname Sheets 1 UsedRange Copy Range A65536 End xlUp Offset 1 0 Workbooks dirname Close False End If dirname Dir Loop End Sub