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

OKJSJSF

在一个工作簿中联合多个工作表再创建透视表的方法适合数据记录较少的情况，如果记录多到超过表格上限就不行（比如联合每天的数据记录，一年366天，比如数据范围扩大至全系统、从村、乡镇扩大至县、市或省）。所以决定学习采用多表直接创建透视表。但为多表写SQL命令也较麻烦，于是决定改为小程序，
按照《excel2007实战技巧精粹》技巧164“多表动态汇总”的办法录了一个宏（空白的透视表，字段由用户自行拖放，以不变应万变）,发现比没有采用“连接‘的单表生成透视表的程序多了太多代码，而且代码顺序与操作顺序并不同，想改成单击按钮执行事件过程的通用宏，不知哪些语句是多余的，怎么改动？数据连接的知识一穷二白，特求助。下面是录制的宏，包含一个工作簿中的四个表，黄色底纹是变量。
Option Explicit

Sub Macro1()
'
' Macro1 Macro
'

'
    With ActiveWorkbook.Connections("贷款明细2").OLEDBConnection
        .BackgroundQuery = True
        .CommandText = Array( _
        "select ""贷"" , * from [贷$] union all select ""款"" , * from [款$] union all select ""明"" , * from [明$] union all select ""细""" _
        , " , * from [细$]")
        .CommandType = xlCmdTable
        .Connection = Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=C:\Users\Administrator\Desktop\贷款明细2.xlsm;Mode=Share Den" _
        , _
        "y Write;Extended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Je" _
        , _
        "t OLEDB:Engine 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 Cop" _
        , _
        "y Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=Fals" _
        , "e")
        .RefreshOnFileOpen = True
        .SavePassword = False
        .SourceConnectionFile = ""
        .SourceDataFile = "C:\Users\Administrator\Desktop\贷款明细2.xlsm"
        .ServerCredentialsMethod = xlCredentialsMethodIntegrated
        .AlwaysUseConnectionFile = False
        .ServerFillColor = False
        .ServerFontStyle = False
        .ServerNumberFormat = False
        .ServerTextColor = False
    End With
    With ActiveWorkbook.Connections("贷款明细2")
        .Name = "贷款明细2"
        .Description = ""
    End With
    Workbooks("贷款明细2.xlsm").Connections.Add "贷款明细2", "", Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=C:\Users\Administrator\Desktop\贷款明细2.xlsm;Mode=Share Den" _
        , _
        "y Write;Extended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Je" _
        , _
        "t OLEDB:Engine 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 Cop" _
        , _
        "y Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=Fals" _
        , "e"), Array( _
        "select ""贷"" , * from [贷$] union all select ""款"" , * from [款$] union all select ""明"" , * from [明$] union all select ""细""" _
        , " , * from [细$]"), 3
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:= _
        ActiveWorkbook.Connections("贷款明细2"), Version:=xlPivotTableVersion12). _
        CreatePivotTable TableDestination:="多表动态汇总!R1C1", TableName:="数据透视表1", _
        DefaultVersion:=xlPivotTableVersion12
    Cells(1, 1).Select
    ActiveWorkbook.ShowPivotTableFieldList = True
    ActiveSheet.PivotTables("数据透视表1").ShowDrillIndicators = False
    ActiveSheet.PivotTables("数据透视表1").HasAutoFormat = False
    ActiveSheet.PivotTables("数据透视表1").RowAxisLayout xlTabularRow
End Sub

OKJSJSF

虽然看上去很多代码，实际上大部份是自动的、默认的。我仅仅操作了选择文件，勾选打开时刷新，录入命令文本，取消展开折叠按钮，取消自动列宽，采用表格形式布局等，仅仅单击关联宏的按钮是会出错的，无法执行的。

OKJSJSF

激活汇总表，单击选项卡的组中的命令按钮，（其他表联合缓存），立即生成空的透视表。

OKJSJSF

    <button id="button25" visible="true" label="一簿多表汇总透视" enabled="true" image="图标名" size="large"  screentip="命令按钮button25" supertip="汇总表激活后单击命令，生成数据透视表，简化手工操作。" keytip="V"/>

OKJSJSF

如果我做不出来，我就只能在手工操作过程中，单击按钮，用循环语句获取其他表的名称，生成SQL命令文本，复制到粘贴板。再手工粘贴到《连接属性定义》文本框中。

OKJSJSF

OKJSJSF 发表于 2021-4-11 12:42
如果我做不出来，我就只能在手工操作过程中，单击按钮，用循环语句获取其他表的名称，生成SQL命令文本，复 ...

VBA这样太初级了。

OKJSJSF

Excel 开发人员参考
PivotCache.Recordset 属性
返回或设置一个 Recordset 对象，该对象作为指定查询表的数据源。可读写。
语法
表达式.Recordset
表达式   一个代表 PivotCache 对象的变量。
说明
如果此属性用来覆盖现有记录集，更改将在运行 Refresh 方法时生效。
示例
此示例在活动工作表的 A3 单元格上，通过连接到 Microsoft Jet 上的 ADO 创建一个新的数据透视表高速缓存，然后再基于该高速缓存新建一个数据透视表。
Visual Basic for Applications
Dim cnnConn As ADODB.Connection
Dim rstRecordset As ADODB.Recordset
Dim cmdCommand As ADODB.Command

' Open the connection.
Set cnnConn = New ADODB.Connection
With cnnConn
    .ConnectionString = _
        "Provider=Microsoft.Jet.OLEDB.4.0"
    .Open "C:\perfdate\record.mdb"
End With

' Set the command text.
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand
    .CommandText = "Select Speed, Pressure, Time From DynoRun"
    .CommandType = adCmdText
    .Execute
End With

' Open the recordset.
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand

' Create a PivotTable cache and report.
Set objPivotCache = ActiveWorkbook.PivotCaches.Add( _
    SourceType:=xlExternal)
Set objPivotCache.Recordset = rstRecordset
With objPivotCache
    .CreatePivotTable TableDestination:=Range("A3"), _
        TableName:="Performance"
End With

With ActiveSheet.PivotTables("Performance")
    .SmallGrid = False
    With .PivotFields("Pressure")
        .Orientation = xlRowField
        .Position = 1
    End With
    With .PivotFields("Speed")
        .Orientation = xlColumnField
        .Position = 1
    End With
    With .PivotFields("Time")
        .Orientation = xlDataField
        .Position = 1
    End With
End With

' Close the connections and clean up.
cnnConn.Close
Set cmdCommand = Nothing
Set rstRecordSet = Nothing
Set cnnConn = Nothing

OKJSJSF

Private Sub CommandButton1_Click()
    Dim str As String
    Dim stri As String
    Dim i As Integer
    Dim sh As Worksheet
    Dim sql As String
    Dim objcn As New ADODB.Connection
    Range("a2:b65536").ClearContents
    Application.ScreenUpdating = False
    str = Dir(ActiveWorkbook.Path & "\*.xlsx")
    Do
        If InStr(1, str, "汇总") = 0 Then
            objcn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data Source=" & ThisWorkbook.Path & "\" & str
            For Each sh In Worksheets
                stri = sh.Name
                If sql = "" Then
                    sql = "select * from [" & stri & "$]"
                Else
                    sql = sql & " union all select * from [" & stri & "$]"
                End If
            Next
            i = [A65536].End(xlUp).Row + 1
            Cells(i, 1).CopyFromRecordset objcn.Execute(sql)
            objcn.Close
            Set objcn = Nothing
        End If
        str = Dir
    Loop Until Len(str) = 0
    Application.ScreenUpdating = True

End Sub

OKJSJSF

Sub Macro1()
    Dim sh As Worksheet
    Dim SQL$
    For Each sh In Worksheets
        If sh.Name <> ActiveSheet.Name Then      '排除当前工作表，如果全部都要，去掉本If语句
            If SQL <> "" Then SQL = SQL & " union all "
            SQL = SQL & "select * from [" & sh.Name & "$]"
        End If
    Next
    MsgBox SQL
End Sub

OKJSJSF

Sub Macro1()
    Dim sh As Worksheet
    Dim SQL$
    For Each sh In Worksheets
        If sh.Name <> ActiveSheet.Name Then      '排除当前工作表，如果全部都要，去掉本If语句
            If SQL <> "" Then SQL = SQL & " union all "
            SQL = SQL & "select """ & sh.Name & """ , * from [" & sh.Name & "$]"
'            SQL = SQL & "select * from [" & sh.Name & "$]"
        End If
    Next
    MsgBox SQL
End Sub