之前文章《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
举例,并与“合并工作簿7”对比
合并与 “合并工作簿7” 举例中同样的数据
共有12个文件夹60个工作簿180个工作表,合并后
运行速度对比
代码版本 | 合并工作簿7.1 | 合并工作簿7.2 | ADO合并工作簿 |
---|---|---|---|
耗时秒数 | 40-60 | 22.5-29 | 5.77-6.76 |
相比 合并工作簿7.2 使用ADO代码行数更少,同时运行速度提升了数倍