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

swordgard

真正的好东西啊，拜谢LZ～不愧是侠圣级别的大神！！！

WW16Z

认真学习了！

gohrfang

弱弱的问一下，2007的怎么使用这个做？

zhaogang1960

原帖由 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 编辑 ]

AVEL

hehe 感谢赵刚老师分享工具。。

panan12301

神仙啊 以后再多表也不怕 不怕啦

zhaogang1960

原帖由 panan12301 于 2011-6-20 21:23 发表
神仙啊 以后再多表也不怕 不怕啦

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

zhc19620430

VBA 使用到这种地步，真让人钦佩。谢谢分享。

商人

赵刚老师是湖南的吗？

非常感谢了，你的作品太给力了！！！

zhaogang1960

原帖由 商人 于 2011-6-21 01:19 发表
赵刚老师是湖南的吗？

非常感谢了，你的作品太给力了！！！

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

俺乃山东青岛银，现在陕西西安打工