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

使用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 = newshe.UsedRange.Rows.Count + 1 Cells(s, 1) = wb.Name '写入数据所属的工作簿名字 s = s + 1 wb.Close '关闭工作簿 na = Dir() '取下一个工作簿 Loop Application.SheetsInNewWorkbook = shes Application.DisplayAlerts = True Range("a1").Select End Sub ///把多个工作簿中的第一个工作表中的数据合并到一个工作簿的一个工作表中 Sub Com() Dim MyPath, MyName, A WbName 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") A WbName = ActiveWorkbook.Name Num = 0 Do While MyName <> "" If MyName <> A WbName 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) & Wb.Name Wb.Close False End With End If MyName = Dir Loop Range("A1").Select 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 V ariant '定义循环变量 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(tempwb.Name, ".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) = "'[" & bk.Name & "]" & sht.Name & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1) End If 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 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 Range("A65536").End(xlUp).Offset(1, 0) Workbooks(dirname).Close False End If dirname = Dir Loop End Sub