一簿中多表创建透视表的练习

OKJSJSF

小结：通过连接缓存办法创建联合查询，如同引用字典功能生成关键字集合与条目，在内存中暂存计算结果，看不见摸不着，但可以随时调用它们。

OKJSJSF

OKJSJSF 发表于 2021-5-14 07:08
这与录制的宏完全不同，sql命令文本中表名称不能用中括号 [  ]

改成中括号 [ ] 可以了，但添加新字段 表名 失败

OKJSJSF

把下面的命令文本语句放进创建透视表的代码中，并不是一件容易的事，还没弄成功。

select "蜀国" as 簿名, * from (select "刘备" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[刘备$] union all select "张飞" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[张飞$] union all select "关羽" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[关羽$]) union all
select "吴国" as 簿名, * from (select "周瑜" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[周瑜$] union all select "鲁肃" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[鲁肃$] union all select "吕蒙" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[吕蒙$])

OKJSJSF

录个宏看下：
Option Explicit

Sub Macro1()
'
' Macro1 Macro
'

'
    With ActiveWorkbook.Connections("蜀吴联盟").OLEDBConnection
        .BackgroundQuery = True
        .CommandText = Array( _
        "select ""蜀国"" as 簿名, * from (select ""刘备"" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[刘备$] union all select ""张飞"" as " _
        , _
        "表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[张飞$] union all select ""关羽"" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm]." _
        , _
        "[关羽$]) union all" & Chr(13) & "" & Chr(10) & "select ""吴国"" as 簿名, * from (select ""周瑜"" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[周瑜$] union a" _
        , _
        "ll select ""鲁肃"" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[鲁肃$] union all select ""吕蒙"" as 表名, * from [G:\office练习\" _
        , "多簿多表联合透视\吴国.xlsm].[吕蒙$])")
        .CommandType = xlCmdTable
        .Connection = Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=G:\office练习\多簿多表联合透视\蜀吴联盟.xlsm;Mode=Share Deny Write;Ext" _
        , _
        "ended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Eng" _
        , _
        "ine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB" _
        , _
        ":New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on" _
        , _
        " Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False" _
        )
        .RefreshOnFileOpen = False
        .SavePassword = False
        .SourceConnectionFile = ""
        .SourceDataFile = "G:\office练习\多簿多表联合透视\蜀吴联盟.xlsm"
        .ServerCredentialsMethod = xlCredentialsMethodIntegrated
        .AlwaysUseConnectionFile = False
        .ServerFillColor = False
        .ServerFontStyle = False
        .ServerNumberFormat = False
        .ServerTextColor = False
    End With
    With ActiveWorkbook.Connections("蜀吴联盟")
        .Name = "蜀吴联盟"
        .Description = ""
    End With
    Workbooks("蜀吴联盟.xlsm").Connections.Add "蜀吴联盟", "", Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=G:\office练习\多簿多表联合透视\蜀吴联盟.xlsm;Mode=Share Deny Write;Ext" _
        , _
        "ended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Eng" _
        , _
        "ine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB" _
        , _
        ":New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on" _
        , _
        " Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False" _
        ), Array( _
        "select ""蜀国"" as 簿名, * from (select ""刘备"" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[刘备$] union all select ""张飞"" as " _
        , _
        "表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm].[张飞$] union all select ""关羽"" as 表名, * from [G:\office练习\多簿多表联合透视\蜀国.xlsm]." _
        , _
        "[关羽$]) union all" & Chr(13) & "" & Chr(10) & "select ""吴国"" as 簿名, * from (select ""周瑜"" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[周瑜$] union a" _
        , _
        "ll select ""鲁肃"" as 表名, * from [G:\office练习\多簿多表联合透视\吴国.xlsm].[鲁肃$] union all select ""吕蒙"" as 表名, * from [G:\office练习\" _
        , "多簿多表联合透视\吴国.xlsm].[吕蒙$])"), 3
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:= _
        ActiveWorkbook.Connections("蜀吴联盟"), Version:=xlPivotTableVersion12). _
        CreatePivotTable TableDestination:="分类汇总!R1C1", TableName:="数据透视表1", _
        DefaultVersion:=xlPivotTableVersion12
    Cells(1, 1).Select
End Sub

OKJSJSF

生成同一文件夹中多工作簿联合查询的连接属性的SQL命令文本的vba代码，具体如下：
Dim filename As String
    Dim sh As Worksheet
    Dim sql As String
    Dim sql2 As String
    filename = Dir(ThisWorkbook.Path & "\*.xls*")
    Do While filename <> ""
        If filename <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & filename
            For Each sh In Worksheets
                If sql <> "" Then sql = sql & " union all "
                sql = sql & "select """ & sh.Name & """ as 表名, * from [" & ActiveWorkbook.FullName & "].[" & sh.Name & "$]"
            Next
            If sql2 <> "" Then sql2 = sql2 & " union all "
            sql2 = sql2 & "select """ & ActiveWorkbook.Name & """ as 簿名, * from(" & sql & ")"
            sql = ""
            ActiveWorkbook.Close False
        End If
        filename = Dir
    Loop
    ThisWorkbook.Worksheets(1).Cells(1) = sql2
最后把字符串写进单元格。程序为了加快速度，采用联合其他所有工作簿的所有工作表的所有字段列，不再在执行时精挑细选哪些簿、表、列。

OKJSJSF

终于用VBA完成了多簿多表的透视表创建，代码如下：
Sub cb27(control As IRibbonControl)
    If MsgBox("打开（或新建）工作簿，单击本按钮，可以对本文件夹中的其他工作簿的各分表（首行须为列标题）直接联合创建透视表。记录增减可以刷新页面，但工作簿增减须重新创建。" & Chr(10) & "如果不用本功能或想全手工操作，请单击“取消”或“X”。", vbOKCancel + vbInformation, "功能说明：") <> vbOK Then Exit Sub
    Dim subfile As String, subpath As String
    Dim filename As String
    Dim sh As Worksheet
    Dim sql$, sql2$
    Dim pc As PivotCache, pt As PivotTable, pf As PivotField
    Dim i As Byte
    subfile = ActiveWorkbook.Name
    subpath = ActiveWorkbook.Path
    filename = Dir(subpath & "\*.xls*")
    Application.ScreenUpdating = False    For i = 1 To ActiveWorkbook.Connections.Count
        ActiveWorkbook.Connections(1).Delete     '删除簿中原所有连接
    Next
    For Each pt In ActiveSheet.PivotTables         '删除先前的所有数据透视表，目的在编辑代码时易于调试！
        pt.TableRange2.Clear    '在没有页字段时可采用TableRange1.Clear方法来清除透视表。pt.TableRange2表示全选透视表单元格！
    Next pt
    Do While filename <> ""
        If filename <> subfile Then
            Workbooks.Open subpath & "\" & filename
            For Each sh In Worksheets
                If sql <> "" Then sql = sql & " union all "
                sql = sql & "select """ & sh.Name & """ as 表名, * from [" & ActiveWorkbook.FullName & "].[" & sh.Name & "$]"     '在一个工作簿的表间联合查询的同时添加工作表名称字段，也可以同时添加工作簿名称字段
            Next
            If sql2 <> "" Then sql2 = sql2 & " union all "
            sql2 = sql2 & "select """ & ActiveWorkbook.Name & """ as 簿名, * from(" & sql & ")"     '在一个工作簿的联合查询完毕时一次性添加本工作簿名称字段，并赋予新的查询名称，再创建簿间联合查询
            sql = ""     '删除原表间查询
            ActiveWorkbook.Close False
        End If
        filename = Dir
    Loop
    Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal)    '2007版在活动工作簿的透视表缓存集合中创建一个缓存，采用2003版的PivotCaches.Add方法不行，数据源类型为导入外部数据（连接），可忽略另二个参数
    With pc
'        .Connection = Array("ODBC;DSN=excel files;DBQ=" & ActiveWorkbook.FullName & ";DefaultDir=" & subpath)        '使用connection确定外部数据源的连接方式为ODBC，文件类型为excel文件，确定数据源的位置和默认文件夹的位置！
        .Connection = Array("OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";")     '连接字符串，上行代码不行
        .CommandType = xlCmdSql        '命令类型
        .CommandText = Split(Replace(sql2, ") union", ")@okjsjsf@ union"), "@okjsjsf@")     '返回命令文本的数组表达式。不能直接把联合查询字符串直接放入array函数中，要按工作簿个数分解为相应数量元素的数组，分解的位置也有讲究，只能工作簿层次的 union 单词的空格前面，被这坑了太长日子！
        .RefreshOnFileOpen = True     '打开时刷新
    End With
    Set pt = pc.CreatePivotTable(tabledestination:=Cells(1), tablename:="pt1")    '创建透视表，指定透视表放置的单元格地址，指定透视表的名称
    With pt
        .ShowDrillIndicators = False     '隐藏展开收缩按钮
        .HasAutoFormat = False     '更新时不自动调整列宽
        .RowAxisLayout xlTabularRow     '以表格形式显示报表布局
        .AllowMultipleFilters = True      '每个字段允许多个筛选
        For Each pf In .PivotFields
            pf.Subtotals(1) = False      '不显示分类汇总
        Next
    End With
    Cells(1).Select
    Application.ScreenUpdating = True
    Set pt = Nothing
    Set pc = Nothing
    Set pf = Nothing
    Set sh = Nothing
End Sub

OKJSJSF

[attachimg]2635
昨天在工作表名称上加上数字，就无法创建透视表，如上出错提示！怪！

OKJSJSF

二个工作簿中都有非数字工作表名称时，可以创建透视

OKJSJSF

第一个工作簿中有非数字工作表名称，第二个工作簿工作表名称都带有数字，也能创建透视

OKJSJSF

今天这时怎么所有表名都有数字也能创建透视表了？一会儿可以，一会儿又不可以！