根据变量范围过滤数据透视表

我的目标是使用另一张工作表中的范围来过滤数据透视表。该范围从第三张表中提取数据，这是启动大量公式并在每次使用时发生变化的数据转储。

我有下面的代码，但我可以看到它所做的是运行每个数据透视表字段，将其与范围进行比较，然后删除过滤器。我有 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

从很多方面来说，你的代码都会变慢。读一下我的关于这个主题的博文如果您有兴趣了解过滤数据透视表时要避免的瓶颈。

下面的代码应该可以帮助您入门。如果您有任何疑问，请大声喊叫。

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