之前文章《Excel·VBA合并工作簿（7，合并子文件夹同名工作簿中同名工作表，纵向汇总数据）》处理合并工作簿问题，代码运行速度比较慢
而《Excel·VBA使用ADO读取工作簿工作表数据》读取数据非常快，那么是否可以使用ADO合并工作簿？
ADO合并子文件夹同名工作簿中同名工作表，纵向汇总数据
注意：合并生成结果表格不带格式，公式都读取为值，仅适用表头行1行，仅测试xlsx格式文件合并
vbnet
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举例，并与"合并工作簿7"对比
合并与 "合并工作簿7" 举例中同样的数据
共有12个文件夹60个工作簿180个工作表，合并后
运行速度对比
| 代码版本 | 合并工作簿7.1 | 合并工作簿7.2 | ADO合并工作簿 |
|---|---|---|---|
| 耗时秒数 | 40-60 | 22.5-29 | 5.77-6.76 |
相比 合并工作簿7.2 使用ADO代码行数更少，同时运行速度提升了数倍