Excel·VBA使用ADO合并工作簿

之前文章《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, ppDim 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 = TimerIf fso.FolderExists(save_path) Then Debug.Print "保存文件夹已存在，会导致错误，请删除": Exit SubFor Each f In fso.GetFolder(file_path).SubFolders  '获取所有子文件夹名s = s & delimiter & f.NameNextfd = 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 fdFor Each f In fso.GetFolder(file_path & p).Files  '空文件夹不影响If f.Name Like "*.xlsx" And Not dict.Exists(f.Name) Thens = 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).FilesIf ff.Name = s Thenfp = file_path & pp & "\" & s  '文件名含路径cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & fpSet rs = cnn.OpenSchema(20): ss = ""Do Until rs.EOF  '获取所有工作表名称If rs.Fields("TABLE_TYPE") = "TABLE" Thens1 = Replace(rs("TABLE_NAME").Value, "'", "")If Right(s1, 1) = "$" Then s1 = Left(s1, Len(s1) - 1): ss = ss & delimiter & s1End Ifrs.MoveNextLooprs.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.NameNextwrite_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) = ppEnd WithElseWith 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) = ppEnd WithEnd IfNextcnn.CloseEnd IfNextNextwrite_wb.Worksheets(1).Delete  'excel新建wb第1个ws为空表If Not old_name Then  '无需写入原子文件夹名For Each sht In write_wb.Worksheetssht.Columns("a:a").DeleteNextEnd Ifwrite_wb.SaveAs filename:=save_path & swrite_wb.Close (False)End IfNextNextSet rs = Nothing: Set cnn = NothingApplication.ScreenUpdating = True: Application.DisplayAlerts = TrueDebug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub