ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 3214|回复: 12

[分享] 用SQL in excel汇总同一文件夹下的多个工作簿数据到总表

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-11-3 01:54 | 显示全部楼层 |阅读模式
本帖最后由 用心修炼 于 2019-11-3 02:20 编辑

小弟不才,初学VBA几个月,接触了一点ADO的基础知识,本人的工作的也是经常需要把多个工作簿中的多张sheet表汇总在一起(所有sheet中的数据结构一摸一样),用SQL语句写了一段代码,分享出来一起学习,附件中有3个工作簿,一共18张sheet,运行完3秒不到,感觉速度还是不够快,不知道是不是我的电脑配置不行。也请大佬们指点一下,看看有没有地方可以进一步优化,提升代码的运行效率。


Function 数据提取(data_path As String, sht_name()) As Variant
Dim cnn As Object, rst As Object
Dim m&, sql$
Set cnn = CreateObject("adodb.connection")
'用ADO的open方法连接数据源,此处data_path变量是工作簿的完整路径
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;hdr=yes';data source=" & data_path
'sql语句赋给变量时,变量类型为字符串型,使用union all关键字的目的是将同一工作簿中的多个sheet表的数据汇总在一起
For m = 1 To UBound(sht_name)
    sql = sql & " union all " & "select * from [" & sht_name(m) & "$]"
Next
sql = Mid$(sql, 12)
'提交SQL语句,并将结果记录集返回给对象
Set rst = cnn.Execute(sql)
'getrows方法将结果记录集返回给一个variant型变量(通常是数组,下标从0开始,且该数组直接写入单元格时是横向排列)
数据提取 = rst.getrows
cnn.Close
Set cnn = Nothing
End Function


Sub test()
Dim wb_name$, mypath$, wb As Workbook, sht As Worksheet, arr_sht(), brr, crr(1 To 5000, 1 To 6)
Dim sht_count&, i&, j&, x&, y&
j = 0
Const str As String = "总表.xlsm"
Application.ScreenUpdating = False
wb_name = Dir(ThisWorkbook.Path & "\")
Do While Len(wb_name) <> 0
    If wb_name <> str Then
        Set wb = GetObject(ThisWorkbook.Path & "\" & wb_name)
        mypath = wb.FullName
        sht_count = wb.Worksheets.Count
        ReDim arr_sht(1 To sht_count)
'将工作簿中的所有工作表名称写入数组,作为function函数的第二参数
        For Each sht In wb.Worksheets
            i = i + 1
            arr_sht(i) = sht.Name
        Next
        wb.Close 0
        Set wb = Nothing: Set sht = Nothing
'调用上面的function函数,并将每次循环到的工作簿路径和该工作簿中的所有工作表名作为参数传递给function函数
        brr = 数据提取(mypath, arr_sht)
        For x = 0 To UBound(brr, 2)
            j = j + 1
            For y = 0 To 5
                crr(j, y + 1) = brr(y, x)
            Next
        Next
        i = 0
    End If
    wb_name = Dir
Loop
Range("A:A,D:D").NumberFormatLocal = "@"
Range("a1").Resize(1, 6) = [{"月","日","凭证编号","科目编号","科目名称","金额"}]
Range("a2").Resize(j, 6) = crr
Application.ScreenUpdating = True
End Sub

待汇总数据.zip

83.29 KB, 下载次数: 66

附件

TA的精华主题

TA的得分主题

发表于 2019-11-3 12:02 来自手机 | 显示全部楼层
brr = 数据提取(mypath, arr_sht)
        For x = 0 To UBound(brr, 2)
            j = j + 1
            For y = 0 To 5
                crr(j, y + 1) = brr(y, x)
            Next
        Next

getrows是不是可以用copyfromrecordset代替,这样子循环会少点,另外,数据多的话可以考虑数据库的。

TA的精华主题

TA的得分主题

发表于 2019-11-3 15:32 | 显示全部楼层
看看这个,在我的电脑上用时是你写的代码的运行时间的大约四分之一。

daihuizong.zip

90.08 KB, 下载次数: 90

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-11-3 15:51 | 显示全部楼层
Option Explicit
Sub test()
Dim Cn As Object, Rs As Object, Sq$, p$, f$, s$
Set Cn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
Application.ScreenUpdating = False
Cells.ClearContents
Range("a1").Resize(1, 6) = [{"月","日","凭证编号","科目编号","科目名称","金额"}]
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Sq = ""
        Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & p & f
        Set Rs = Cn.OpenSchema(20) '不必打开工作簿,那很慢的
        Do Until Rs.EOF
            If Rs.Fields("TABLE_TYPE") = "TABLE" Then
                s = Replace(Rs("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                        Sq = Sq & " UNION ALL " & "SELECT * FROM [" & s & "A1:F]"
                    End If
            End If
            Rs.MoveNext
        Loop
        Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset Cn.Execute(Mid(Sq, 12))
        Rs.Close
        Cn.Close
    End If
    f = Dir
Loop
Set Cn = Nothing
Set Rs = Nothing
Application.ScreenUpdating = True
MsgBox "ok!", 64
End Sub

评分

3

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-11-3 16:09 | 显示全部楼层
xiangbaoan 发表于 2019-11-3 15:51
Option Explicit
Sub test()
Dim Cn As Object, Rs As Object, Sq$, p$, f$, s$

有些属性和方法还不太理解,还需要学习,谢谢老师指点

TA的精华主题

TA的得分主题

发表于 2019-11-3 16:22 | 显示全部楼层
用心修炼 发表于 2019-11-3 16:09
有些属性和方法还不太理解,还需要学习,谢谢老师指点

也是学生,正在学习的路上……

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-11-3 16:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 用心修炼 于 2019-11-3 16:57 编辑
xiangbaoan 发表于 2019-11-3 16:22
也是学生,正在学习的路上……

老师,Set Rs = Cn.OpenSchema(20),这样设置以后,RS返回的结果集将不再是字段名,Rs.EOF表示的是表名结果集不为空吗?如果工作簿中可用表有多个的话,需要用movenext方法来逐一获取,另外要返回工作表名称固定写法是RS("TABLE_NAME").value,是这样理解的吗?

TA的精华主题

TA的得分主题

发表于 2019-11-3 16:50 | 显示全部楼层
用心修炼 发表于 2019-11-3 16:40
老师,Set Rs = Cn.OpenSchema(20),这样设置以后,RS返回的结果集将不再是字段名,如果工作簿中可用表有 ...

是这样吧,不过
RS("TABLE_NAME").value 不一定是工作表,还有自定义的名称
是工作表的话后有一$ 符号 ,这还要判断。

Set Rs = Cn.OpenSchema(20) 'OpenSchema方法获取表的信息,参数20仅指表(可是工作表,也可是定义的单元格区域名称)
Do Until Rs.EOF '当EOF属性不为真时,此点可百度一下,作详细了解
    If Rs.Fields("TABLE_TYPE") = "TABLE" Then '判断类型是否为 表
        S = Replace(Rs("TABLE_NAME").Value, "'", "") '替换掉名称前面的撇号',工作表名以数字开头的有撇号,如 '1月$
        If Right(S, 1) = "$" Then '判断是不是工作表,是工作表的后面有一 $ ,形如 1月$,自定义名称则木有。
        …………SQL语句
        End If
    End If
    Rs.MoveNext '将记录前移一条
Loop

TA的精华主题

TA的得分主题

发表于 2019-11-3 18:12 | 显示全部楼层
xiangbaoan 发表于 2019-11-3 16:50
是这样吧,不过
RS("TABLE_NAME").value 不一定是工作表,还有自定义的名称
是工作表的话后有一$ 符号  ...

这种在实例中的说明,胜过十本经典教材对特定内容的讲解,是最最宝贵的教材!

TA的精华主题

TA的得分主题

发表于 2019-11-4 11:33 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 18:24 , Processed in 0.057568 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表