Excel·VBA使用ADO合并工作簿

之前文章《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代码行数更少,同时运行速度提升了数倍

相关推荐
不剪发的Tony老师2 小时前
Valentina Studio:一款跨平台的数据库管理工具
数据库·sql
重生之我要当java大帝2 小时前
java微服务-尚医通-编写医院设置接口下
java·开发语言·sql
杀气丶3 小时前
L2JBR - 修复数据库编码为UTF8
数据库·sql·oracle
冼紫菜3 小时前
[特殊字符] 深入理解 PageHelper 分页原理:从 startPage 到 SQL 改写全过程
java·后端·sql·mysql·spring
CodeCraft Studio3 小时前
国产化Excel开发组件Spire.XLS教程:将Python列表转换为Excel表格(3种实用场景)
开发语言·python·excel·spire.xls·python列表转excel·国产化文档开发
青山撞入怀11143 小时前
sql题目练习-子查询
java·数据库·sql
企鹅侠客3 小时前
基于python写的PDF表格提取到excel文档
python·pdf·excel·pdf文档表格转excel
!if5 小时前
springboot mybatisplus 配置SQL日志,但是没有日志输出
spring boot·sql·mybatis
忘忧记5 小时前
Excel VLOOKUP函数完全教程:从基础到高级实战
excel
葡萄城技术团队5 小时前
突破Excel局限!SpreadJS让电子表格“活”起来
java·数据库·excel