前提: 每个表格的数据格式一致,包含有表头、子表格不能有刷选操作。
Sub 合并() If MsgBox("是否要汇总明细表?", vbYesNo + vbInformation) = vbNo Then '提示是否汇总 Exit Sub End If On Error Resume Next '如遇错误继续运行 Application.ScreenUpdating = False '关闭屏幕刷新 Application.DisplayAlerts = False '禁用警告提示 Dim ws As Worksheet Dim i%, fileNum%, deletRow%, sheetsSum% Dim sheetNum, sheetName, sheetNameArray Dim sheetRowTotalArray() As Integer '定义一个动态数组,用于判断合并表格是否成功 sheetNameArray = Array("工作簿1", "工作簿2") '定义工作簿名称 sheetsSum = UBound(sheetNameArray) - LBound(sheetNameArray) + 1 '计算工作簿总个数 ReDim sheetRowTotalArray(sheetsSum) '定义数组长度 '遍历新增工作簿 sheetNum = 1 For Each sheetName In sheetNameArray ThisWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count) '新增工作簿 ThisWorkbook.Sheets(sheetNum).Name = sheetName '重命名工作簿 sheetRowTotalArray(sheetNum) = 0 '初始化每一个汇总工作簿的总行数 sheetNum = sheetNum + 1 Next sheetName Dim path, fileName '定义路径名,被合并表名称 Dim sourceWb As Workbook path = ThisWorkbook.path '指定路径为合并新表所在路径 fileName = Dir(path & "\" & "*-特定后缀.xlsx") '从该文件夹内遍历所有要合并的表格 fileNum = 0 '初始化当前是打开了第几个表格文件 Do While fileName <> "" '遍历的表格名不为空就进入循环 Set sourceWb = Workbooks.Open(path & "\" & fileName) '打开遍历到的表格 sheetNum = 1 '初始化工作簿索引 For Each sheetName In sheetNameArray i = ThisWorkbook.Sheets(sheetNum).Range("A" & Rows.Count).End(xlUp).Row + 1 '获取汇总表中A列数据区域最后一行的行号 sourceWb.Sheets(sheetNum).UsedRange.Copy '复制分表中的数据 ThisWorkbook.Sheets(sheetNum).Cells(i, 1).PasteSpecial Paste:=xlPasteAll '粘贴数据 ThisWorkbook.Sheets(sheetNum).Cells(i, 1).PasteSpecial Paste:=xlPasteColumnWidths '粘贴列宽 sheetRowTotalArray(sheetNum) = sheetRowTotalArray(sheetNum) + sourceWb.Sheets(sheetNum).UsedRange.Rows.Count '叠加每一个工作簿的总行数 '如果当前表格文件不是第一个打开的,则删除该表格工作薄的表头 If fileNum > 0 Then ThisWorkbook.Sheets(sheetNum).Rows(i).Delete End If sheetNum = sheetNum + 1 Next sheetName sourceWb.Close (False) '复制粘贴完成后关闭被合并的表 fileName = Dir '继续遍历 fileNum = fileNum + 1 Loop '数据校验和清理 ' ' ' Dim tmpRowTotal% '定义一个临时变量 Dim isSuccess As Boolean '定义是否合并成功 isSuccess = True sheetNum = 1 For Each sheetName In sheetNameArray tmpRowTotal = ThisWorkbook.Sheets(sheetNum).UsedRange.Rows.Count + 1 '获取当前工作簿的总行数,需要加一行 If tmpRowTotal <> sheetRowTotalArray(sheetNum) Then '判断是否全部拷贝过来了 isSuccess = False ThisWorkbook.Sheets(sheetName).Delete '按名称删除工作簿 Else ThisWorkbook.Sheets(sheetNum).Rows(1).Delete '遍历删除表格的第一行,因为是空白行 End If sheetNum = sheetNum + 1 Next sheetName If isSuccess Then ThisWorkbook.Sheets(sheetNum).Delete '删除最后一个工作簿 MsgBox "工作表合并完毕" Else MsgBox "合并失败,总行数不相等!!!" End If Application.DisplayAlerts = True '恢复警告提示 Application.ScreenUpdating = True '开启屏幕刷新 End Sub