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

swordgard · 发表于 2011-4-4 13:16

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

WW16Z · 发表于 2011-4-12 22:17

认真学习了！

gohrfang · 发表于 2011-4-15 14:50

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

zhaogang1960 · 发表于 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 编辑 ]

AVEL · 发表于 2011-6-20 18:34

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

panan12301 · 发表于 2011-6-20 21:23

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

zhaogang1960 · 发表于 2011-6-20 21:31

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

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

zhc19620430 · 发表于 2011-6-20 22:00

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

商人 · 发表于 2011-6-21 01:19

赵刚老师是湖南的吗？

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

zhaogang1960 · 发表于 2011-6-21 17:17

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

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

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

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

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

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

评分