Excel·VBA合并工作簿2-Toy模板网

这篇具有很好参考价值的文章主要介绍了Excel·VBA合并工作簿2。希望对大家有所帮助。如果存在错误或未考虑完全的地方，请大家不吝赐教，您也可以点击"举报违法"按钮提交疑问。

其他合并工作簿的方法，见之前的文章《Excel·VBA合并工作簿》

8，合并文件夹下所有工作簿中所有工作表，按表头汇总

8.1，打开工作簿方法

与之前的文章《Excel·VBA合并工作簿（3，合并文件夹下所有工作簿中所有工作表）》类似，但是按照表头名称，将表格数据汇总至合并表格，表头名称相同的在同一列

Sub 合并文件夹下所有工作簿中所有工作表_按表头汇总()
    '文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夹），并按表头汇总数据，默认只有1行表头
    Dim dict As Object, fso As Object, write_ws As Worksheet, wb As Workbook, sht As Worksheet
    Dim write_row&, write_col&, sht_row&, file_path$, file_name$, old_name As Boolean, arr, i&, k
'--------------------参数填写：file_path，待合并工作簿所在的文件夹；old_name
    file_path = "E:\测试\拆分表\合并工作簿8\"
    file_name = Dir(file_path & "*.xlsx")
    old_name = True    '写入原工作簿、工作表名称，是/否
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For Each sht In wb.Worksheets
            If WorksheetFunction.CountA(sht.UsedRange.Cells) <> 0 Then  '非空工作表
                If write_ws Is Nothing Then
                    sht.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.Count
                    write_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].CurrentRegion
                    For i = 1 To UBound(arr, 2)
                        dict(arr(1, i)) = i  '记录表头名称及列号
                    Next
                Else
                    write_row = write_ws.UsedRange.Rows.Count + 1
                    sht_row = sht.UsedRange.Rows.Count: arr = sht.[a1].CurrentRegion
                    For 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_col
                            sht.Cells(1, i).Copy write_ws.Cells(1, write_col)
                        End If
                        sht.Cells(2, i).Resize(sht_row - 1, 1).Copy write_ws.Cells(write_row, dict(k))
                    Next
                    write_ws.Cells(write_row, "a").Resize(sht_row - 1, 2) = Array(fso.GetBaseName(file_name), sht.Name)
                End If
            End If
        Next
        wb.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 = True
    Debug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub

举例

共5个工作簿13个工作表，并且改变了C、D列的顺序
合并结果

8.2，SQL方法

与之前的文章《Excel·VBA使用ADO合并工作簿》合并工作簿的速度提升了数倍，那么是否可以使用同样的方法解决本问题？

Sub 合并文件夹下所有工作簿中所有工作表_按表头汇总ADO()
    '不打开工作簿方法；title_str中的表头必须每个工作表都包含，否则报错
    Dim cnn As Object, rs As Object, fso As Object, write_ws As Worksheet, old_name As Boolean
    Dim title_str$, write_row&, file_path$, file_name$, s$, ss$, ws, wss, sqlstr$, trr
'--------------------参数填写：file_path，待合并工作簿所在的文件夹；old_name；title_str
    file_path = "E:\测试\拆分表\合并工作簿8\"
    file_name = Dir(file_path & "*.xlsx")
    old_name = True    '写入原工作簿、工作表名称，是/否
    title_str = "序号,姓名,worksheet,属地"  '需要的表头名称及顺序，用英文逗号分隔
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Set fso = CreateObject("Scripting.FileSystemObject"): delimiter = Chr(28): tm = Timer
    Set cnn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
    
    Do While file_name <> ""
        cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & file_path & file_name
        Set rs = cnn.OpenSchema(20): ss = ""
        Do Until rs.EOF  '获取所有工作表名称
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                s = Replace(rs("TABLE_NAME").Value, "'", "")
                If Right(s, 1) = "$" Then s = Left(s, Len(s) - 1): ss = ss & delimiter & s
            End If
            rs.MoveNext
        Loop
        rs.Close: wss = Split(Mid(ss, 2), delimiter): sqlstr = ""  '工作表名称数组
        For Each ws In wss
            sqlstr = sqlstr & " union all select " & title_str & " FROM [" & ws & "$]"
        Next
        sqlstr = Mid(sqlstr, 12)  '去除第1个select之前的内容
        If write_ws Is Nothing Then
            Set write_ws = Workbooks.Add.ActiveSheet: write_ws.Name = "合并表"  '新建工作表
            With write_ws  '写入表头、数据、原工作簿名称
                trr = Split(title_str, ","): .[b1].Resize(1, UBound(trr) + 1) = trr
                .[a1] = "原工作簿名称": .[b2].CopyFromRecordset cnn.Execute(sqlstr)
                .[a2].Resize(.[b1].End(xlDown).row - 1, 1) = fso.GetBaseName(file_name)
            End With
        Else
            With write_ws  '写入、数据、原工作簿名称
                write_row = .UsedRange.Rows.Count + 1: s = fso.GetBaseName(file_name)
                .Cells(write_row, 2).CopyFromRecordset cnn.Execute(sqlstr)
                .Cells(write_row, 1).Resize(.[b1].End(xlDown).row - write_row + 1, 1) = s
            End With
        End If
        cnn.Close: file_name = Dir   '下一个文件名
    Loop
    '保存文件
    If Not old_name Then write_ws.Columns("a:a").Delete  '无需写入原工作簿名称
    write_ws.Parent.SaveAs filename:=file_path & "合并表.xlsx"
    write_ws.Parent.Close (False)
    Set rs = Nothing: Set cnn = Nothing: Application.ScreenUpdating = True
    Debug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub