Excel VBA データソースの異なるピボットテーブルのスライサーを連動させる

はじめに

ピボットテーブルのスライサーは、データソースが同じ場合、レポートの接続で別のピボットテーブルのスライサーと連動させることができる。
しかし、データソースが違う場合、レポートの接続で連動させることができない。
そのため、データソースの異なるピボットテーブルのスライサーを連動させる方法を考えたい。

作成したいマクロのイメージ

ピボットテーブルのスライサーを変更した時に処理を実行する。
変更したスライサーの項目のオン/オフを他のスライサーに適用する。
データソースが異なるため、同じ項目があるとは限らないので、対応が必要。

作成したマクロの概要

ThisworkbookモジュールのWorkbookのイベントの「SheetPivotTableChangeSync」を使い、ブック内のピボットテーブルが変更されたときに処理を実行する。
変更したスライサーのオンになっている項目を取得し、連動させたいスライサーのフィルターをクリアして、連動させたいスライサーの項目のうち、変更したスライサーでオンになっている項目以外はオフにする。（スライサーの全ての項目をオフにすると、その時点でフィルターがクリアされ、全てオンになってしまうため、この方法をとった。）

また、データソースとなるテーブルに「(該当なし)」データを追加し、もし、変更したスライサーのオンになっている項目が、連動させたいスライサーに存在しない項目のみの場合、連動させたいスライサーの項目全てをオフにすることはできないため、「(該当なし)」をオンにする対応とした。

動作手順

1. ブック内のテーブル(ListObject)とピボットテーブルをコレクションとして取得する
2. ブック内のテーブル(ListObject)に「(該当なし)」のデータを追加する
3. 追加した「(該当なし)」データを反映するため、ブック内のピボットテーブルを更新する
4. ブック内にあるスライサーに対して、変更したスライサーの項目のオン/オフを適用する
   4-1. 変更したスライサーのオンになっている項目(VisibleSlicerItems)を取得する
   4-2. 変更したスライサーと同じタイトルの連動させたいスライサーに対して処理を行う
   　4-2-1. 連動させたいスライサーの設定を変更したスライサーの設定と同じにする
   　(設定を変更すると、スライサーの項目の表示が更新される)
   　4-2-2. 連動させたいスライサーのフィルターをクリアする
   　4-2-3. 連動させたいスライサーの項目を取得する
   4-3.連動させたいスライサーの各項目に対して処理を行う
   (変更したスライサーのフィルターがクリアされている場合は、クリア状態なので終了)
   　4-3-1. 各項目が変更したスライサーのオンになっている項目以外の場合、オフにする
   　4-3-2. オンになっている最後の項目をオフにする場合、「(該当なし)」をオンにする

注意事項

• 各項目に対してオフにする作業を行うため、オフの項目数が増えるほど、処理に時間がかかる
• テーブルのスライサーも連動する仕組みだが、テーブルのスライサーを変更した際のイベントは存在しないため、テーブルのスライサーを変更した際には、連動させられなかった　

完成したマクロ

前提として、ピボットテーブルのデータソースは同じファイル内にあるテーブル(ListObject)とする。
連動させたいスライサー同士のタイトルを一致させておく(データソースとなるテーブルの項目ラベルを同じにする)。

Thisworkbook

Private Sub Workbook_SheetPivotTableChangeSync(ByVal Sh As Object, ByVal Target As PivotTable)

Dim ChangedSlicer As Slicer
Dim ChangedSlicerCache As SlicerCache
Dim VisibleChangedItemsDic As Object
Dim TargetItemsDic As Object
Dim TargetSlicerCache As SlicerCache
Dim SlicerItemName As String
Dim TargetSheet As Worksheet
Dim TargetListObjects As Collection
Dim TargetPivotTables As Collection
Dim SetRange As Range
Dim i As Long

    If Target.Slicers.Count = 0 Then Exit Sub

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set TargetListObjects = New Collection
    Set TargetPivotTables = New Collection
    
    For Each TargetSheet In ThisWorkbook.Worksheets
         For i = 1 To TargetSheet.ListObjects.Count
            TargetListObjects.Add TargetSheet.ListObjects(i)   
         Next i
         For i = 1 To TargetSheet.PivotTables.Count   
             TargetPivotTables.Add TargetSheet.PivotTables(i)  
         Next i    
    Next TargetSheet

    For i = 1 To TargetListObjects.Count
        With TargetListObjects(i)
            If WorksheetFunction.CountIf(.ListColumns(1).Range, "(該当なし)") = 0 Then
                Set SetRange = .Range.Resize(.Range.Rows.Count + 1, .Range.Columns.Count)
                .Resize SetRange
                .ListRows(.ListRows.Count).Range.Value = "(該当なし)"
            End If
        End With
    Next i
    
    For i = 1 To TargetPivotTables.Count 
        TargetPivotTables(i).RefreshTable
    Next i
  
    Set TargetListObjects = Nothing
    Set TargetPivotTables = Nothing

        
    For Each ChangedSlicer In Target.Slicers
        
        Set ChangedSlicerCache = ChangedSlicer.SlicerCache
        Set VisibleChangedItemsDic = CreateObject("Scripting.Dictionary")
                      
        For i = 1 To ChangedSlicerCache.VisibleSlicerItems.Count
            SlicerItemName = ChangedSlicerCache.VisibleSlicerItems(i).Name
            VisibleChangedItemsDic.Add SlicerItemName, SlicerItemName
        Next i 
  
        For Each TargetSlicerCache In ThisWorkbook.SlicerCaches
        
           If TargetSlicerCache.Name <> ChangedSlicerCache.Name _
                And TargetSlicerCache.SourceName = ChangedSlicerCache.SourceName Then
                
                 With TargetSlicerCache
                    .CrossFilterType = ChangedSlicerCache.CrossFilterType
                    .SortItems = ChangedSlicerCache.SortItems
                    .SortUsingCustomLists = ChangedSlicerCache.SortUsingCustomLists
                    .ShowAllItems = ChangedSlicerCache.ShowAllItems
                    .ClearAllFilters
                End With
                
                If Not ChangedSlicerCache.FilterCleared Then
          
                    Set TargetItemsDic = CreateObject("Scripting.Dictionary")
                    
                    For i = 1 To TargetSlicerCache.SlicerItems.Count   
                        SlicerItemName = TargetSlicerCache.SlicerItems(i).Name
                        TargetItemsDic.Add SlicerItemName, SlicerItemName
                    Next i
                   
                    For i = 0 To TargetItemsDic.Count - 1
                        If Not VisibleChangedItemsDic.Exists(TargetItemsDic.Items()(i)) Then
                            With TargetSlicerCache
                                If .VisibleSlicerItems.Count = 1 Then 
                                     .SlicerItems("(該当なし)").Selected = True
                                End If
                                .SlicerItems(TargetItemsDic.Items()(i)).Selected = False
                            End With
                        End If
                    Next i  
                End If   
             End If
             
             Set TargetItemsDic = Nothing  
             
        Next TargetSlicerCache
        
        Set ChangedSlicerCache = Nothing
        Set VisibleChangedItemsDic = Nothing   
        
    Next ChangedSlicer
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

サンプルファイル保存先：