Excel·VBA使用ADO合并工作簿

news2024/11/15 20:09:40

之前文章《Excel·VBA合并工作簿（7，合并子文件夹同名工作簿中同名工作表，纵向汇总数据）》处理合并工作簿问题，代码运行速度比较慢
而《Excel·VBA使用ADO读取工作簿工作表数据》读取数据非常快，那么是否可以使用ADO合并工作簿？

ADO合并子文件夹同名工作簿中同名工作表，纵向汇总数据

注意：合并生成结果表格不带格式，公式都读取为值，仅适用表头行1行，仅测试xlsx格式文件合并

Sub ADO合并子文件夹同名工作簿中同名工作表_纵向汇总数据2()
    '不打卡工作簿方法；最终合并文件以工作簿名命名，适用工作表格式相同；合并文件A列显示原子文件夹名
    Dim dict As Object, fso As Object, old_name As Boolean, write_wb As Workbook, s$, s1$, ss$
    Dim file_path$, save_path$, delimiter$, fd, i&, r&, f, ff, p, pp
    Dim cnn As Object, rs As Object, ex As Object, sqlstr$, fp$, ws, wss
'--------------------参数填写：
    file_path = "E:\测试\拆分表\合并工作簿7\"  'file_path待合并的子文件夹所在文件夹
    save_path = file_path + "合并表\"   '合并后的表格保存路径
    old_name = True    '写入原子文件夹名，是/否
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    Set dict = CreateObject("scripting.dictionary"): delimiter = Chr(28)
    Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
    If fso.FolderExists(save_path) Then Debug.Print "保存文件夹已存在，会导致错误，请删除": Exit Sub
    For Each f In fso.GetFolder(file_path).SubFolders  '获取所有子文件夹名
        s = s & delimiter & f.Name
    Next
    fd = Split(Mid(s, 2), delimiter)
    If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
    Set cnn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
    For Each p In fd
        For Each f In fso.GetFolder(file_path & p).Files  '空文件夹不影响
            If f.Name Like "*.xlsx" And Not dict.Exists(f.Name) Then
                s = f.Name: Set dict(s) = CreateObject("scripting.dictionary")
                Set write_wb = Workbooks.Add  '新建工作簿，合并文件
                For Each pp In fd  '遍历所有子文件夹同名工作簿
                    For Each ff In fso.GetFolder(file_path & pp).Files
                        If ff.Name = s Then
                            fp = file_path & pp & "\" & s  '文件名含路径
                            cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & fp
                            Set rs = cnn.OpenSchema(20): ss = ""
                            Do Until rs.EOF  '获取所有工作表名称
                                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                                    s1 = Replace(rs("TABLE_NAME").Value, "'", "")
                                    If Right(s1, 1) = "$" Then s1 = Left(s1, Len(s1) - 1): ss = ss & delimiter & s1
                                End If
                                rs.MoveNext
                            Loop
                            rs.Close: wss = Split(Mid(ss, 2), delimiter)  '工作表名称数组
                            For Each ws In wss  '遍历工作表获取数据，并写入
                                sqlstr = "SELECT * FROM [" & ws & "$]"
                                Set ex = cnn.Execute(sqlstr)
                                If Not dict(s).Exists(ws) Then  '工作表不存在
                                    dict(s)(ws) = "": i = 0: ReDim trr(1 To ex.Fields.Count)
                                    For Each x In ex.Fields  '表头
                                        i = i + 1: trr(i) = x.Name
                                    Next
                                    write_wb.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = ws  '最后添加新sheet，并命名
                                    With write_wb.Worksheets(ws)
                                        .[b1].Resize(1, UBound(trr)) = trr
                                        .[b2].CopyFromRecordset ex
                                        .[a1] = "子文件夹": .[a2].Resize(.[b1].End(xlDown).row - 1, 1) = pp
                                    End With
                                Else
                                    With write_wb.Worksheets(ws)
                                        r = .UsedRange.Rows.Count + 1
                                        .Cells(r, 2).CopyFromRecordset ex
                                        .Cells(r, 1).Resize(.[b1].End(xlDown).row - r + 1, 1) = pp
                                    End With
                                End If
                            Next
                            cnn.Close
                        End If
                    Next
                Next
                write_wb.Worksheets(1).Delete  'excel新建wb第1个ws为空表
                If Not old_name Then  '无需写入原子文件夹名
                    For Each sht In write_wb.Worksheets
                        sht.Columns("a:a").Delete
                    Next
                End If
                write_wb.SaveAs filename:=save_path & s
                write_wb.Close (False)
            End If
        Next
    Next
    Set rs = Nothing: Set cnn = Nothing
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
    Debug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub