利用VBA快速整合多个excel文件

Sub 合并当前目录下所有工作簿的全部工作表() '表示当前的过程的名称 '定义对应的变量名称 Dim mypath, myname, awbname Dim wb As Workbook, wbn As String Dim g As Long Dim num As Long Dim box As String Dim count As Long Dim place As Long Dim temp As Long '关闭excel的刷新 Application.ScreenUpdating = False '禁止弹出对话框 Application.DisplayAlerts = False '得到本文件的相对地址 mypath = ActiveWorkbook.Path '得到这个文件夹下的某个文件的文件名 myname = Dir(mypath & '\' & '*.xls') '当前工作的excel的文件名 awbname = ActiveWorkbook.Name num = 0 place = 3 '如果当前的文件名为空的字符串（''）表示已经没有更多的文件了跳出循环 Do While myname <> '' '需要的就是下面这个条件，每个文件名都不一样 If myname <> awbname Then '把每一个文件都打开 Set wb = Workbooks.Open(mypath & '\' & myname) num = num + 1 '计算非空行数量 count = application.counta(range('c:c')) 'MsgBox count wb.Sheets(1).Range('a5', wb.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell)).Copy '从a5开始到已用区域最后一个单元格的范围全部复制 ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Range('C65536').End(xlUp).Row + 2 , 1).PasteSpecial Paste:=xlValues '从c列最后一个有数据的单元格后的空格开始粘贴 '下面开始合并需要的单元格 temp = count + place - 2 ThisWorkbook.Sheets(1).Range('A' & place & ':A' & temp).Merge ThisWorkbook.Sheets(1).Range('B' & place & ':B' & temp).Merge ThisWorkbook.Sheets(1).Range('H' & place & ':H' & temp).Merge ThisWorkbook.Sheets(1).Range('I' & place & ':I' & temp).Merge '对每个队伍重新编号 ThisWorkbook.Sheets(1).Range('A' & place).Value = num place = place + count wbn = wbn & Chr(13) & wb.Name wb.Close False End If myname = Dir Loop Range('a1').Select Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox '共合并了' & num & '个工作薄下的全部工作表。'如下：' & Chr(13) & wbn, vbInformation, '提示' End Sub