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

zhaogang1960

使用vba生成汇总多个工作簿的多工作表数据透视表SQL命令文本


前几天偶尔看到论坛上关于利用数据透视表汇总多个工作簿内的多工作表数据的帖子，感到很神奇，原来可以通过SQL命令导入数据生成数据透视表。也看到了要汇总多个工作表时，要使用UNION ALL 把每个工作表的语句连接起来，人工写挺麻烦的，特别是列数（字段）不等情况下进行多表汇总，判断工作表是否是空表等。下面我们探讨使用vba生成汇总多个工作簿内的多工作表数据透视表SQL命令文本：

程序分以下三种方式：
1、历遍本文件夹——自连接，生成SQL含有各工作簿路径，路径为本文件夹
2、指定多个工作簿——自连接，生成SQL含有各工作簿路径，路径可以用打开对话框指定
3、指定一个工作簿——直接连接到该工作簿，生成SQL不含该工作簿路径，效果和一个工作簿中多个工作表联合查询一致

三种方式代码原理基本相同，首先是逐个工作簿查询工作表名，再逐表查询字段名，查出某个工作簿有哪些工作表，某个工作表有几个字段，最后调出窗体，生成SQL命令。

请注意:46楼有更正,请在46楼下载最新附件.

使用vba生成透视表SQL命令文本(不同工作簿).rar (82.57 KB, 下载次数: 3224)

2010-12-26 15:16 上传

点击文件名下载附件

数据透视合并计算.rar (197.56 KB, 下载次数: 3498)

2010-12-26 15:16 上传

点击文件名下载附件

不同工作簿2007、2007(兼容2003).rar (203.79 KB, 下载次数: 2221)

2011-4-19 09:31 上传

点击文件名下载附件

[ 本帖最后由 wuxiang_123 于 2011-6-22 10:29 编辑 ]

zhaogang1960

下面是“历遍本文件夹” 调出窗体前的代码：
'引用Microsoft Scripting Runtime
'引用Microsoft AD0 Ext 2.8 for DDL and Security
'引用Microsoft ActiveX Data Objects 2.x Library
Public d As New Dictionary
Public ds As New Dictionary
Public dic As New Dictionary
Public Mypath$, flag As Boolean

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")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            n = n + 1
            If n = 1 Then cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & Mypath & MyFile '连接第一个工作簿
            cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.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 8.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(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

调出窗体后就可以选择字段生成单个工作表的短SQL语句：
Private Sub CommandButton1_Click() '显示短sql
    Dim s$, i%
    s = "SELECT "
    If CheckBox1.Value Then s = s & "*,"
    For i = 0 To d.Count - 1 '逐个动态添加的复选框对应着字典记录的字段名
        If Me.Controls("CheckBox" & i + 2).Value Then s = s & d.Keys(i) & ","
    Next
    TextBox1.Text = Left(s, Len(s) - 1) & " FROM " & IIf(flag, "[工作表名]", "`路径`.`工作表名`")
End Sub

生成短SQL语句后可以进行编辑，如调整字段顺序、修改别名、添加where语句等。

下面是根据单个工作表短SQL语句生成SQL命令文本代码：
Private Sub CommandButton3_Click() '生成长sql
    Dim s$, a, arr(), i%, j%, m%, temp$, str1$, s1$, s2$
    s = TextBox1.Text
    s1 = Split(s, ",")(0)
    s2 = Split(s, "FROM")(1)
    With ListView1
        If InStr(s, ",") > 0 And InStr(s, "*") = 0 Then '含有字段名，不含有"*"
            If InStr(Split(s, "FROM")(0), "as") = 0 Then '含有as
                a = Split(Split(s, " ")(1), ",") '字段数组
            Else
                a = Split(Split(Split(s, "as")(UBound(Split(s, "as"))), " ")(1), ",")
            End If
            For i = 1 To .ListItems.Count '逐行ListView1数据
                If .ListItems(i).Checked = True Then '选中
                    m = m + 1
                    ReDim Preserve arr(1 To m) '重新定义数组，以保存第m个工作表的SQL语句
                    For j = 0 To UBound(a) '逐个用逗号隔开的字段
                        If d.Exists(a(j)) Then '字典存在，即确认是工作表中存在的字段
                            If InStr(ds(.ListItems(i).Text & .ListItems(i).SubItems(1)), a(j) & ",") Then '该工作表存在该字段
                                arr(m) = arr(m) & a(j) & ","
                            Else
                                arr(m) = arr(m) & "0 as " & a(j) & "" & "," '该工作表不存在该字段要添加 0 as 字段
                            End If
                        End If
                    Next
                    If InStr(s, "SELECT ""工作簿名""") > 0 Then
                        temp = Replace(s1, "工作簿名", .ListItems(i).Text) & "," '用真正的工作簿名替换“工作簿名”
                    ElseIf InStr(s, "SELECT ""工作表名""") > 0 Then
                        temp = Replace(s1, "工作表名", .ListItems(i).SubItems(1)) & "," '用真正的工作表名替换“工作表名”
                    Else
                        temp = "SELECT "
                    End If
                    str1 = Replace(s2, "路径", Mypath & .ListItems(i).Text) '用真正的路径替换“路径”
                    str1 = Replace(str1, "工作表名", .ListItems(i).SubItems(1)) '用真正的工作表名替换from后面的“工作表名”
                    If CheckBox102.Value Then '工作表别名
                        arr(m) = temp & Left(arr(m), Len(arr(m)) - 1) & " FROM" & str1 & " `" & .ListItems(i).SubItems(1) & "`"
                    Else
                        arr(m) = temp & Left(arr(m), Len(arr(m)) - 1) & " FROM" & str1 & ""
                    End If
                End If
            Next
        ElseIf InStr(s, "*") > 0 Then '含有"*"，如果含有字段名也不做判断是否在工作表中存在，假定如果有字段也是都有的
            For i = 1 To .ListItems.Count
                If .ListItems(i).Checked = True Then
                    m = m + 1
                    ReDim Preserve arr(1 To m)
                    If InStr(s, "SELECT ""工作簿名""") > 0 Then
                        temp = Replace(s1, "工作簿名", .ListItems(i).Text) & ","
                    ElseIf InStr(s, "SELECT ""工作表名""") > 0 Then
                        temp = Replace(s1, "工作表名", .ListItems(i).SubItems(1)) & ","
                    Else
                        temp = "SELECT "
                    End If
                    str1 = Replace(s2, "路径", Mypath & .ListItems(i).Text)
                    str1 = Replace(str1, "工作表名", .ListItems(i).SubItems(1))
                    If CheckBox102.Value Then '工作表别名
                        arr(m) = temp & "* FROM" & str1 & " `" & .ListItems(i).SubItems(1) & "`"
                    Else
                        arr(m) = temp & "* FROM" & str1
                    End If
                End If
            Next
        End If
    End With
    If m > 0 Then TextBox2.Text = Join(arr, " UNION ALL ") Else TextBox2.Text = "" '各个工作表的SQL语句用UNION ALL连接显示在TextBox2
End Sub
其他子程序就不再赘述了，附件中都标注着它们的用途。

由于对数据透视表理解不深，本方法就算是一个尝试吧，还请数据透视表高手来完善此方案。
附件中用了下面二位的附件：
yanjie版主的《透视表汇总5个工作簿》：http://club.excelhome.net/viewth ... 3208&highlight=
www8358坛友的《数据透视合并计算》：http://club.excelhome.net/thread-666030-1-1.html
在此表示衷心感谢。



[ 本帖最后由 zhaogang1960 于 2010-12-26 17:46 编辑 ]

wuxiang_123

学习了.谢谢 很厉害

mn860429

很佩服vba用的好的人

zhaogang1960

谢谢二位支持

camle

下来学习学习,多谢lz!

wangtx218

真的不懂！

algatross

先mark下，慢慢学习，正需要写一个多表数据透视再汇总的marco

rockhat

太好了，这个VB做得很实用。非常感谢。有空也学习一下