ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[分享] 透视表汇总多工作簿数据!(令人惊叹的功能!)--第二部

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2009-4-22 18:53 | 显示全部楼层 |阅读模式
透视表汇总多工作簿数据!(令人惊叹的功能!)--第二部
不过其中两个列头是有规律的 : "部门名称"  ,"科目代码"
1,不等表(每个工作簿中工作表数量不等,名称没有规律)
2,不等列(每个工作簿中工作表每 列 的数量,名称(字段)不等)
3,可以有空表,将忽略过去。

Option Explicit

Sub 多工作表透视汇总()
    Dim ws As Worksheet
    Dim pc As PivotCache
    Dim pt As PivotTable
    Dim str As String
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim s As String
    Dim f As String
    Dim arr() As Variant
    Dim brr() As Variant
    Dim sqlstr As String
    Dim str2 As String
    Dim d As Object
    Dim Conn As New ADODB.Connection
    f = Dir(ThisWorkbook.Path & "\*.xls")
    Application.ScreenUpdating = False
   
    Set d = CreateObject("scripting.dictionary")          '删除先前的所有数据透视表,目的在编辑代码时易于调试!

    For Each pt In Sheet1.PivotTables
        pt.TableRange2.Clear    '在没有页字段时可采用TableRange1.Clear方法来清除透视表 _
                                。pt.TableRange2表示全选透视表单元格!
    Next pt

                                      '设置透视表的缓存,采用PivotCaches.Add方法,确定数据源的类型为引用外部数据源!
    Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)

    With pc
                                                       '使用connection确定外部数据源的连接方式为ODBC, _
                                                        文件类型为excel文件,确定数据源的位置和默认文件夹的位置!
        .Connection = Array("ODBC;DSN=excel files;DBQ=" & str & ";DefaultDir=" & ThisWorkbook.Path)

        .CommandType = xlCmdSql                            '返回命令类型!本例为返回excel的SQL命令。

        s = "SELECT @ FROM `" & ThisWorkbook.Path & "\"
        Do While f <> ""
            If f <> ThisWorkbook.Name Then
                Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " _
                        & " extended properties=excel 8.0;" _
                        & " Data Source=" & ThisWorkbook.Path & "\" & f
                Dim Cat As New ADOX.Catalog
                Set Cat.ActiveConnection = Conn
                Dim cTab As ADOX.Table
                Dim fld As ADOX.Column
                For Each cTab In Cat.Tables
                    str = ""
                    For Each fld In cTab.Columns
                        If fld <> "F1" Then
                            If Not d.exists(fld.Name) And fld.Name <> "部门名称" And fld.Name <> "科目代码" Then
                                k = k + 1
                                d(fld.Name) = k
                                sqlstr = sqlstr & "  " & fld.Name
                            End If
                            str = str & "  " & fld.Name
                            If Not d.exists(f & cTab.Name & "表") Then
                                i = i + 1
                                d(f & cTab.Name & "表") = i
                                ReDim Preserve arr(1 To i)
                                arr(i) = s & Left(f, Len(f) - 4) & "`.`" & cTab.Name & "`"
                                If Not d.exists(f & "工作簿") Then
                                    j = j + 1
                                    d(f & "工作簿") = ""
                                    If j > 1 Then arr(i) = "] " & arr(i)
                                End If
                            End If
                        End If
                    Next
                    ReDim Preserve brr(1 To i)
                    If str <> "" Then brr(i) = str
                Next
                Conn.Close
            End If
            f = Dir()
        Loop
        For k = 1 To i
            str2 = ""
            For j = 0 To UBound(Split(sqlstr, "  "))
                If InStr(brr(k), Split(sqlstr, "  ")(j)) Then
                    If str2 <> "" Then str2 = str2 & ","
                    str2 = str2 & Split(sqlstr, "  ")(j)
                Else
                    If str2 <> "" Then str2 = str2 & ","
                    str2 = str2 & " 0 as " & Split(sqlstr, "  ")(j)
                End If

            Next
            arr(k) = Replace(arr(k), "@", " 部门名称,科目代码," & str2)
        Next
        str = Replace(Join(arr, "  / UNION ALL "), "UNION ALL ]", " / UNION ALL ")
        
        .CommandText = Split(str, "/")

    End With
   
    Set pt = pc.CreatePivotTable(tabledestination:=Sheet1.Cells(4, 1), tablename:="pt1")
   
    pt.ManualUpdate = True     '停止透视表的计算,为快速向透视表添加字段做准备!

                               '使用AddFields方法为数据表添加行,列和页字段,本例中“Data” _
                                为虚拟的数据字段,表示数据字段放置在透视表的列区域!
    pt.AddFields RowFields:="部门名称", ColumnFields:="Data"
   
    k = 0
    For i = 1 To pt.PivotFields.Count
        If pt.PivotFields(i) <> "部门名称" And pt.PivotFields(i) <> "科目代码" Then
            k = k + 1
            With pt.PivotFields(i)
                .Orientation = xlDataField
                .Position = k
                .Name = " " & pt.PivotFields(i)
            End With
        End If
    Next

    pt.ManualUpdate = False        '透视表添加完字段后,重新计算数据透视表,以显示正确结果。
    pt.ManualUpdate = True
    Application.ScreenUpdating = True
   
    Set pt = Nothing               '释放变量占用的内存!
    Set pc = Nothing
    Set ws = Nothing

End Sub

[ 本帖最后由 office2008 于 2009-4-22 19:41 编辑 ]

不等表不等列.rar

56.64 KB, 下载次数: 2420

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2009-4-22 19:44 | 显示全部楼层
谢谢分享。很好。这个难度是有点 了。

TA的精华主题

TA的得分主题

发表于 2009-4-22 20:02 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-4-22 20:13 | 显示全部楼层

回复 3楼 yanjie 的帖子

呵呵,这些都是你的代码,我只是作了一点修改,其实对数据透视表一点都不会,请指出错误的地方,可及时改正。

TA的精华主题

TA的得分主题

发表于 2009-4-22 21:24 | 显示全部楼层
不敢,不敢,我好多地方还不懂!还得向你请教。

TA的精华主题

TA的得分主题

发表于 2009-4-22 21:32 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
能详细讲解一下吗,我对字典得应用很少,几乎没有接触过ADOX。
对查询中很长的字符串的表示方法感到很困难!但是它确实很有用。

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-4-22 21:46 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
我一定会仔细加入注释的,其实我跟你一样,看别人的代码不习惯,因为写的方式不一样顺序规则也不一样再加上我上面的代码比较乱没有整成标准一点的,一下子看不来,明天一定把注释写上。

TA的精华主题

TA的得分主题

发表于 2009-4-23 19:14 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-4-24 08:18 | 显示全部楼层
真的很复杂啊,还是手工做数据透视表了

TA的精华主题

TA的得分主题

发表于 2009-4-24 11:32 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 15:41 , Processed in 0.056407 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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