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

zhaogang1960 · 发表于 2010-12-26 15:16

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

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

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

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

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

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

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

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

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

zhaogang1960 · 发表于 2010-12-26 15:17

下面是“历遍本文件夹” 调出窗体前的代码：
'引用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 · 发表于 2010-12-26 15:19

调出窗体后就可以选择字段生成单个工作表的短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 · 发表于 2010-12-26 15:36

学习了.谢谢

很厉害

mn860429 · 发表于 2010-12-26 15:37

很佩服vba用的好的人

zhaogang1960 · 发表于 2010-12-26 16:05

谢谢二位支持

camle · 发表于 2010-12-26 17:05

下来学习学习,多谢lz!

wangtx218 · 发表于 2010-12-26 17:23

真的不懂！

algatross · 发表于 2010-12-29 11:08

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

rockhat · 发表于 2011-1-2 05:56

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

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分

回复 4楼 wuxiang_123 5楼 mn860429 的帖子