使用VBA合并多个Excel工作簿的几个例子

Sub 合并工作簿()
Application.DisplayAlerts = False '关闭提示窗口
shes = Application.SheetsInNewWorkbook '工作簿中包含工作表数
Application.SheetsInNewWorkbook = 1 '生成的新工作簿中只有一个工作表
Set newbok = Workbooks.Add '生成新工作簿
Set newshe = newbok.Worksheets(1) '新工作表
s = 1 '从新工作表的第一行写入数据
na = Dir("d:\123\*.xls") '需要合并的所有工作表都要事先保存在D盘time文件夹下
Do While na <> ""
Set wb = Application.Workbooks.Open("d:\123\" & na)
wb.Worksheets(1).UsedRange.Copy '复制数据
newbok.Activate
Cells(s, 1).Select
ActiveSheet.Paste '执行粘贴
s = https://www.wendangku.net/doc/a818409945.html,edRange.Rows.Count + 1
Cells(s, 1) = https://www.wendangku.net/doc/a818409945.html, '写入数据所属的工作簿名字
s = s + 1
wb.Close '关闭工作簿
na = Dir() '取下一个工作簿
Loop
Application.SheetsInNewWorkbook = shes
Application.DisplayAlerts = True
Range("a1").Select
End Sub


///把多个工作簿中的第一个工作表中的数据合并到一个工作簿的一个工作表中

Sub Com()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = https://www.wendangku.net/doc/a818409945.html,
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Wb.Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & https://www.wendangku.net/doc/a818409945.html,
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub


///把多个工作簿中所有工作表合并到一个工作表中

Sub Books2Sheets()
'定义对话框变量
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)

'新建一个工作簿
Dim newwb As Workbook
Set newwb = Workbooks.Add

With fd
If .Show = -1 Then
'定义单个文件变量
Dim vrtSelectedItem As Variant

'定义循环变量
Dim i As Integer
i = 1

'开始文件检索
For Each vrtSelectedItem In .SelectedItems
'打开被合并工作簿
Dim tempwb As Workbook
Set tempwb = Workbooks.Open(vrtSelectedItem)

'复制工作表
tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)

'把新工作簿的

工作表名字改成被复制工作簿文件名，这儿应用于xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsx
newwb.Worksheets(i).Name = VBA.Replace(https://www.wendangku.net/doc/a818409945.html,, ".xls", "")

'关闭被合并工作簿
tempwb.Close SaveChanges:=False

i = i + 1
Next vrtSelectedItem
End If
End With

Set fd = Nothing
End Sub


///合并所有的工作簿中的第一个工作表到一个工作簿中
///求所有工作表指定单元格的和例：=sum(sheet1:sheet8!A1)



Sub CombineWorkbooks()
Dim strFileName As String
Dim wb As Workbook
Dim ws As Object

'包含工作簿的文件夹,可根据实际修改
Const strFileDir As String = "D:\示例\数据记录\"

Application.ScreenUpdating = False

Set wb = Workbooks.Add(xlWorksheet)
strFileName = Dir(strFileDir & "*.xls*")

Do While strFileName <> vbNullString
Dim wbOrig As Workbook
Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)

For Each ws In wbOrig.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.Close SaveChanges:=False

strFileName = Dir

Loop

Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True

Set wb = Nothing

End Sub


使用VBA合并多个Excel工作簿
例如，需要将多个Excel工作簿中的工作表合并到一个工作簿。这里假设需要合并的工作簿在“D:\示例\数据记录\”文件夹中，含有两个工作簿test1.xls、test2.xls（当然，可以不限于两个），在test1.xls工作簿中含有三张工作表，在test2.xls工作簿中含有两张工作表，现在使用一段VBA代码合并这两个工作簿到一个新工作簿中，合并到新工作簿中的工作表分别以原工作簿名加索引值命名。代码如下：
Sub CombineWorkbooks()
Dim strFileName As String
Dim wb As Workbook
Dim ws As Object

'包含工作簿的文件夹,可根据实际修改
Const strFileDir As String = "D:\示例\数据记录\"

Application.ScreenUpdating = False

Set wb = Workbooks.Add(xlWorksheet)
strFileName = Dir(strFileDir & "*.xls*")

Do While strFileName <> vbNullString
Dim wbOrig As Workbook
Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)

For Each ws

In wbOrig.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.Close SaveChanges:=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实战技巧精粹》中<技巧91：汇总多个工作簿的工作表>所介绍的方法，即合并汇总。
有四个工作簿，分别为：汇总工作簿.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 WbCount As Integer
WbCount = Workbooks.Count
ReDim RangeArray(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) = "'[" & https://www.wendangku.net/doc/a818409945.html, & "]" & https://www.wendangku.net/doc/a818409945.html, & "'!" & _
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 = https://www.wendangku.net/doc/a818409945.html,
dirname = Dir(lj & "\*.xls*")

Cells.Clear

Do While dirname <> ""
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