可変範囲に基づくピボットテーブルのフィルタリング

Question

私の目的は、別のシートの範囲を使用してピボットテーブルをフィルタリングすることです。この範囲は3番目のシートからデータを取り込みます。これは、使用されるたびに数式のホスト全体が起動し、変更されるデータダンプです。

私は以下のコードを持っていますが、私はそれが範囲と比較し、フィルタを削除して、各ピボットテーブルフィールドを実行していることがわかります。私は現在のマクロが使用するには遅すぎるようにチェックする必要がある32,000フィールドを持っています。

空白でない範囲の値に基づいてフィルタリングするようにコードを修正するのに役立つ人はいますか？

Sub PT() 
Dim PT As PivotTable 
Dim PI As PivotItem 
Set PT = Sheets("Pivot_Sheet").PivotTables("PivotTable2") 
With Sheets("Pivot_Sheet").PivotTables("PivotTable2").PivotFields("Product") 
.ClearAllFilters 
End With 
For Each PI In PT.PivotFields("Product").PivotItems 
PI.Visible = WorksheetFunction.CountIf(Sheets("Sheet1").Range("J2:J100"), 
PI.Name) > 0 
Next PI 
Set PT = Nothing 
End Sub 

Answer 1

あなたのコードは多くの、多くのカウントで遅くなるでしょう。ピボットテーブルをフィルタリングするときに回避するボトルネックについて知りたい場合は、blogpost on this subjectを読んでください。

以下のコードを参考にしてください。ご不明な点がございましたら、お気軽にお問い合わせください。

Option Explicit 

Sub FilterPivot() 
Dim pt As PivotTable 
Dim pf As PivotField 
Dim pi As PivotItem 
Dim i As Long 
Dim vItem As Variant 
Dim vList As Variant 

Set pt = ActiveSheet.PivotTables("PivotTable2") 
Set pf = pt.PivotFields("Product") 

vList = Application.Transpose(ActiveWorkbook.Worksheets("Sheet1").Range("J2:J100")) 

pt.ManualUpdate = True 'Stops PivotTable from refreshing after each PivotItem is changed 

With pf 

    'At least one item must remain visible in the PivotTable at all times, so make the first 
    'item visible, and at the end of the routine, check if it actually *should* be visible 
    .PivotItems(1).Visible = True 

    'Hide any other items that aren't already hidden. 
    'Note that it is far quicker to check the status than to change it. 
    ' So only hide each item if it isn't already hidden 
    For i = 2 To .PivotItems.Count 
     If .PivotItems(i).Visible Then .PivotItems(i).Visible = False 
    Next i 

    'Make the PivotItems of interest visible 
    On Error Resume Next 'In case one of the items isn't found 
    For Each vItem In vList 
     .PivotItems(vItem).Visible = True 
    Next vItem 
    On Error GoTo 0 

    'Hide the first PivotItem, unless it is one of the items of interest 
    On Error Resume Next 
    If InStr(UCase(Join(vList, "|")), UCase(.PivotItems(1))) = 0 Then .PivotItems(1).Visible = False 
    If Err.Number <> 0 Then 
     .ClearAllFilters 
     MsgBox Title:="No Items Found", Prompt:="None of the desired items was found in the Pivot, so I have cleared the filter" 
    End If 
    On Error GoTo 0 

End With 

pt.ManualUpdate = False 

End Sub