Excel VBA 创建新的 PivotCache 并连接多个数据透视表

Question

我有一个包含许多数据透视表的工作簿，这些数据透视表基于使用 VBA 删除和刷新的范围。目前，为了更新数据源，作为该子例程的最后一部分，我为每个数据透视表重新创建数据透视缓存并刷新。

我只想将 6 个表与一个公共 PivotCache 链接在一起，以便它们可以共享切片器等，但我无法让它工作。

我找遍了这个问题的解决方案，但我一直没有找到解决方案，现在我已经坚持了很长时间。我是 VBA 的新手，但我通常可以通过反复试验来解决这个问题，但这让我很困惑。

我显然做错了什么，如果能帮助我确定是什么，将不胜感激。

谢谢:)

我现在的代码如下（注意：为了方便阅读，我把代码中不相关的东西去掉了）：

Sub RunReport()


On Error GoTo ErrorHandler

'##############         Define Variables        ##############


    Dim WS_O As Worksheet           'Output sheet - report sheet
    Dim WS_P As Worksheet           'Pivot table Sheet
    Dim OuputRow As Integer         'First row for output of data
    Dim LastRow_O As Integer        'Last used row of output sheet
    Dim PivotCacheName As PivotCache
    Dim PivotRange As String        'Range of data for Pivot Data Source
    Dim PivotName1 As String        'Pivot Table Name Strings
    Dim PivotName2 As String
    Dim PivotName3 As String
    Dim PivotName4 As String
    Dim PivotName5 As String
    Dim PivotName6 As String
    


'##############   Modify Application Settings   ##############

'Store current configuration

    OriginalCalcMode = Application.Calculation
    
'Set configuration for fastest processing

    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False


'##############       Set Variable Values       ##############


'Worksheets

    Set WS_O = Sheets("Report")                             'Output sheet - report sheet
    Set WS_P = Sheets("Pivot Tables - Live Data")           'Pivot tables sheet
    
    
'Pivot Tables

    PivotName1 = "PivotTable1"
    PivotName2 = "PivotTable2"
    PivotName3 = "PivotTable3"
    PivotName4 = "PivotTable4"
    PivotName5 = "PivotTable5"
    PivotName6 = "PivotTable6"
    
    
'General

    OutputRow = 7
    
    
'Used Ranges

    LastRow_O = WS_O.Range("A" & Rows.Count).End(xlUp).Row

 
    
 '##############     Refresh Pivot Tables        ##############


'Define Data Range

    PivotRange = WS_O.Name & "!" & "A" & OutputRow - 1 & ":AM" & LastRow_O


'Error Handling
  
    'Make sure every column in data set has a heading and is not blank
    If WorksheetFunction.CountBlank(WS_O.Range("A" & OutputRow - 1 & ":AM" & LastRow_O).Rows(1)) > 0 Then
        MsgBox "One or more columns in ''Report'' sheet has a blank heading;" & vbNewLine _
        & "This has prevented the pivot tables from refreshing correctly." & vbNewLine & vbNewLine _
        & "Please verify cells A" & OutputRow - 1 & ":AM" & OutputRow - 1 & " in ''Report'' sheet are not blank and try again.", vbCritical, "ERROR - Column Heading Missing"
        GoTo EndSub
    End If


'Change Pivot Data Sources to a single cache

    Set PivotCacheName = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange, Version:=xlPivotTableVersion15)

    WS_P.PivotTables(PivotName1).ChangePivotCache (PivotCacheName)
    WS_P.PivotTables(PivotName2).ChangePivotCache (PivotCacheName)
    WS_P.PivotTables(PivotName3).ChangePivotCache (PivotCacheName)
    WS_P.PivotTables(PivotName4).ChangePivotCache (PivotCacheName)
    WS_P.PivotTables(PivotName5).ChangePivotCache (PivotCacheName)
    WS_P.PivotTables(PivotName6).ChangePivotCache (PivotCacheName)


'Refresh Pivot Tables

    'Turn on auto calc while pivot's update
    Application.Calculation = xlCalculationAutomatic


    WS_P.PivotTables(PivotName1).RefreshTable
    WS_P.PivotTables(PivotName2).RefreshTable
    WS_P.PivotTables(PivotName3).RefreshTable
    WS_P.PivotTables(PivotName4).RefreshTable
    WS_P.PivotTables(PivotName5).RefreshTable
    WS_P.PivotTables(PivotName6).RefreshTable


   
'Completion Confirmation
  
        MsgBox "Report data has been compiled and pivot tables have been successfully refreshed.", vbInformation, "SUCCESS! - Report Compilation Complete"

    
'##############   End Sub and Reset Application Configuration   ##############


'Standard End Sub Functionality (where no undocumented error occurred)

EndSub:
        Application.ScreenUpdating = False
        Application.Calculation = OriginalCalcMode   'Reset calc option to what it was previously
        Application.EnableEvents = True
    Exit Sub


'Error Handling (where an undocumented error occurred - that is, an error without an explainatory message box)

ErrorHandler:
    Application.ScreenUpdating = False
'    Application.Calculation = OriginalCalcMode
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
     MsgBox "An error caused this subroutine to stop working correctly." & vbNewLine _
        & "Contact Administrator for assistance.", vbCritical, "ERROR - Contact Administrator"
       
    
End Sub

我以前使用过这个，但现在仍然是一些我不想使用相同 PivotCache 的表：

'Create new caches for each table

    WS_P.PivotTables(PivotName1).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
        
    WS_P.PivotTables(PivotName2).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
        
    WS_P.PivotTables(PivotName3).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
        
    WS_P.PivotTables(PivotName4).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
        
    WS_P.PivotTables(PivotName5).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
         
    WS_P.PivotTables(PivotName6).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)

我目前在此处收到运行时 438 错误（对象不支持此属性或方法）>>>

    WS_P.PivotTables(PivotName1).ChangePivotCache (PivotCacheName)

编辑：我找到了解决方案并在下面添加了答案。

Answer 1

所以，经过一夜好眠和几个小时的研究，我认为这是一个解决方案。

这可能不是最好的方法，但它有效并且还没有给我带来任何问题...

'Create New Pivot Cache from Data Range
    WS_P.PivotTables(PivotName1).ChangePivotCache _
        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
  
'Link Other Pivot Tables to same Pivot Cache     
  
    WS_P.PivotTables(PivotName2).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
    WS_P.PivotTables(PivotName3).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
    WS_P.PivotTables(PivotName4).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
    WS_P.PivotTables(PivotName5).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
    WS_P.PivotTables(PivotName6).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex

我仍然不确定为什么另一种方法不起作用，所以仍然希望得到一些反馈，如果有人有任何反馈，因为这种方法确实禁止我将切片器附加到所有数据透视表（我必须离开第一个出）。

Excel VBA 创建新的 PivotCache 并连接多个数据透视表

Excel VBA to create new PivotCache and connect multiple Pivot Tables

excel

vba

runtime-error

pivot-table