ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[原创] 使用vba生成汇总多个工作簿的多工作表数据透视表SQL命令文本[46楼有更新]

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2011-4-4 13:16 | 显示全部楼层
本帖已被收录到知识树中,索引项:SQL应用
真正的好东西啊,拜谢LZ~不愧是侠圣级别的大神!!!

TA的精华主题

TA的得分主题

发表于 2011-4-12 22:17 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
认真学习了!

TA的精华主题

TA的得分主题

发表于 2011-4-15 14:50 | 显示全部楼层
弱弱的问一下,2007的怎么使用这个做?

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-4-15 15:31 | 显示全部楼层
原帖由 gohrfang 于 2011-4-15 14:50 发表
弱弱的问一下,2007的怎么使用这个做?

1楼已经上传,第3个附件
2007(不兼容2003):
Sub 历遍本文件夹()
    Dim cnn As New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim cat  As New ADOX.Catalog, tb1 As Table
    Dim SQL$, MyFile$, m%, i%, temp$, strField$, s$, n%
    Mypath = ThisWorkbook.Path & "\"
    MyFile = Dir(Mypath & "*.xlsx")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            n = n + 1
            If n = 1 Then cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile '连接第一个工作簿
            cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile '连接工作簿以利用ADOX取得工作表名
            For Each tb1 In cat.Tables
                If tb1.Type = "TABLE" Then
                    s = Replace(tb1.Name, "'", "") '表名含有“1月”等时有多余的单引号
                    If Right(s, 1) = "$" Then '排除无效表名
                        If n > 1 Then SQL = "select * from [Excel 12.0;Database=" & Mypath & MyFile & "].[" & s & "]" Else SQL = "[" & s & "]"
                        Set rs = cnn.Execute(SQL)
                        If rs.Fields(0).Name <> "F1" Then '第一列没有字段名就认为是空表
                            dic(rs.Fields.Count) = "" '各表字段数不一致,dic.Count将大于1
                            m = m + 1
                            strField = ""
                            For i = 0 To rs.Fields.Count - 1 '历遍每个工作表的每个字段(判断列数不等的依据)
                                temp = rs.Fields(i).Name
                                If Left(temp, 1) <> "F" And IsNumeric(Mid(temp, 2)) = False Then '排除其他可能的空字段
                                    If Not d.Exists(temp) Then d(temp) = "" '字段名写入字典
                                    strField = strField & temp & "," '字段名用逗号连接
                                End If
                            Next
                            ds(MyFile & s) = strField & "," '工作簿名与工作表名连接添加到字典ds键值,字段名连接字符串添加到字典条目
                            UserForm1.ListView1.ListItems.Add , , MyFile 'ListView控件第一列添加工作簿名
'                            ds(Replace(MyFile, ".xlsx", "") & s) = strField & "," '工作簿名与工作表名连接添加到字典ds键值,字段名连接字符串添加到字典条目
'                            UserForm1.ListView1.ListItems.Add , , Replace(MyFile, ".xlsx", "") 'ListView控件第一列添加工作簿名
                            UserForm1.ListView1.ListItems(m).SubItems(1) = s 'ListView控件第二列添加工作表名
                        End If
                    End If
                End If
            Next
        End If
        MyFile = Dir()
    Loop
    If n = 0 Then
        MsgBox "没有发现可以汇总的文件!", vbInformation, "提示"
        Exit Sub
    End If
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set cat = Nothing
    Set tb1 = Nothing
    UserForm1.Show
End Sub

2007(兼容2003):
Sub 历遍本文件夹()
    Dim cnn As New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim cat  As New ADOX.Catalog, tb1 As Table
    Dim SQL$, MyFile$, m%, i%, temp$, strField$, s$, n%
    Mypath = ThisWorkbook.Path & "\"
    MyFile = Dir(Mypath & "*.xls*") '20032007混用,但是不汇总xlsm文件
    Do While MyFile <> ""
        If Right(MyFile, 4) <> "xlsm" Then
'        If MyFile <> ThisWorkbook.Name Then
            n = n + 1
            If n = 1 Then cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile '连接第一个工作簿
            cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile '连接工作簿以利用ADOX取得工作表名
            For Each tb1 In cat.Tables
                If tb1.Type = "TABLE" Then
                    s = Replace(tb1.Name, "'", "") '表名含有“1月”等时有多余的单引号
                    If Right(s, 1) = "$" Then '排除无效表名
                        If n > 1 Then SQL = "select * from [Excel 12.0;Database=" & Mypath & MyFile & "].[" & s & "]" Else SQL = "[" & s & "]"
                        Set rs = cnn.Execute(SQL)
                        If rs.Fields(0).Name <> "F1" Then '第一列没有字段名就认为是空表
                            dic(rs.Fields.Count) = "" '各表字段数不一致,dic.Count将大于1
                            m = m + 1
                            strField = ""
                            For i = 0 To rs.Fields.Count - 1 '历遍每个工作表的每个字段(判断列数不等的依据)
                                temp = rs.Fields(i).Name
                                If Left(temp, 1) <> "F" And IsNumeric(Mid(temp, 2)) = False Then '排除其他可能的空字段
                                    If Not d.Exists(temp) Then d(temp) = "" '字段名写入字典
                                    strField = strField & temp & "," '字段名用逗号连接
                                End If
                            Next
                            ds(MyFile & s) = strField & "," '工作簿名与工作表名连接添加到字典ds键值,字段名连接字符串添加到字典条目
                            UserForm1.ListView1.ListItems.Add , , MyFile 'ListView控件第一列添加工作簿名
'                            ds(Replace(MyFile, ".xls*", "") & s) = strField & "," '工作簿名与工作表名连接添加到字典ds键值,字段名连接字符串添加到字典条目
'                            UserForm1.ListView1.ListItems.Add , , Replace(MyFile, ".xls*", "") 'ListView控件第一列添加工作簿名
                            UserForm1.ListView1.ListItems(m).SubItems(1) = s 'ListView控件第二列添加工作表名
                        End If
                    End If
                End If
            Next
        End If
        MyFile = Dir()
    Loop
    If n = 0 Then
        MsgBox "没有发现可以汇总的文件!", vbInformation, "提示"
        Exit Sub
    End If
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set cat = Nothing
    Set tb1 = Nothing
    UserForm1.Show
End Sub

[ 本帖最后由 zhaogang1960 于 2011-4-19 09:32 编辑 ]

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-6-20 18:34 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
hehe 感谢赵刚老师分享工具。。

TA的精华主题

TA的得分主题

发表于 2011-6-20 21:23 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-20 21:31 | 显示全部楼层
原帖由 panan12301 于 2011-6-20 21:23 发表
神仙啊 以后再多表也不怕 不怕啦

我可不想当神仙,做人多好,可以在论坛上好好享受写代码的乐趣,哈哈

TA的精华主题

TA的得分主题

发表于 2011-6-20 22:00 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2011-6-21 01:19 | 显示全部楼层
赵刚老师是湖南的吗?

非常感谢了,你的作品太给力了!!!

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-21 17:17 | 显示全部楼层
原帖由 商人 于 2011-6-21 01:19 发表
赵刚老师是湖南的吗?

非常感谢了,你的作品太给力了!!!


猜测俺是湖南人有何凭据,莫非商人老师是湖南人?哈哈

俺乃山东青岛银,现在陕西西安打工
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-28 19:10 , Processed in 0.054394 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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