- 其他合并工作簿的方法,见之前的文章《Excel·VBA合并工作簿》
目录
- 8,合并文件夹下所有工作簿中所有工作表,按表头汇总
- 举例
8,合并文件夹下所有工作簿中所有工作表,按表头汇总
与之前的文章《Excel·VBA合并工作簿(3,合并文件夹下所有工作簿中所有工作表)》类似,但是按照表头名称,将表格数据汇总至合并表格,表头名称相同的在同一列
Sub 合并文件夹下所有工作簿中所有工作表_按表头汇总()'文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表(但不含子文件夹),并按表头汇总数据,默认只有1行表头Dim dict As Object, fso As Object, write_ws As Worksheet, wb As Workbook, sht As WorksheetDim write_row&, write_col&, sht_row&, file_path$, file_name$, old_name As Boolean, arr, i&, k
'--------------------参数填写:file_path,待合并工作簿所在的文件夹;old_namefile_path = "E:\测试\拆分表\合并工作簿8\"old_name = True '写入原工作簿、工作表名称,是/否file_name = Dir(file_path & "*.xlsx")Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行Application.DisplayAlerts = False '不显示警告信息Set dict = CreateObject("scripting.dictionary"): tm = TimerSet fso = CreateObject("Scripting.FileSystemObject")Do While file_name <> ""Set wb = Workbooks.Open(file_path & file_name)For Each sht In wb.WorksheetsIf WorksheetFunction.CountA(sht.UsedRange.Cells) <> 0 Then '非空工作表If write_ws Is Nothing Thensht.Copy: Set write_ws = ActiveSheet '整体复制工作表write_ws.Name = "合并表": write_ws.Columns("a:b").Insert '插入列write_ws.[a1].Resize(1, 2) = Array("原工作簿名称", "原工作表名称")write_row = write_ws.UsedRange.Rows.Countwrite_ws.[a2].Resize(write_row - 1, 2) = Array(fso.GetBaseName(file_name), sht.Name)write_col = write_ws.UsedRange.Columns.Count: arr = write_ws.[a1].CurrentRegionFor i = 1 To UBound(arr, 2)dict(arr(1, i)) = i '记录表头名称及列号NextElsewrite_row = write_ws.UsedRange.Rows.Count + 1sht_row = sht.UsedRange.Rows.Count: arr = sht.[a1].CurrentRegionFor i = 1 To UBound(arr, 2)k = arr(1, i)If Not dict.Exists(k) Then '表头不存在,更新至列号+1,复制表头write_col = write_col + 1: dict(k) = write_colsht.Cells(1, i).Copy write_ws.Cells(1, write_col)End Ifsht.Cells(2, i).Resize(sht_row - 1, 1).Copy write_ws.Cells(write_row, dict(k))Nextwrite_ws.Cells(write_row, "a").Resize(sht_row - 1, 2) = Array(fso.GetBaseName(file_name), sht.Name)End IfEnd IfNextwb.Close (False) '关闭工作簿file_name = Dir '下一个文件名Loop'保存文件If Not old_name Then write_ws.Columns("a:b").Delete '无需写入原工作簿、工作表名称write_ws.Parent.SaveAs filename:=file_path & "合并表.xlsx"write_ws.Parent.Close (False)Application.ScreenUpdating = True: Application.DisplayAlerts = TrueDebug.Print "文件夹合并完成,用时:" & Format(Timer - tm, "0.00")
End Sub
举例
- 共5个工作簿13个工作表,并且改变了C、D列的顺序
- 合并结果