基于可变范围过滤数据透视表

My objective is to filter a pivot table using a range in another sheet. This range pulls data from a 3rd sheet, which is the data dump that kicks off a whole hosts of formulas and changes every time it is used.

我的目标是使用另一个工作表中的范围过滤数据透视表。此范围从第三张纸张中提取数据，这是一个数据转储，它启动整个公式的主机并在每次使用时更改。

I have the below code but what I can see it doing is running through each Pivot Table field, comparing it to the range, and then removing the filter. I have 32,000 fields that need to be checked so the current macro is too slow to use.

我有以下代码，但我可以看到它正在运行每个数据透视表字段，将其与范围进行比较，然后删除过滤器。我有32,000个需要检查的字段，因此当前的宏太慢而无法使用。

Could anyone help me fix the code so that it only filters based on values in the range that are Not Blank?

任何人都可以帮我修复代码，以便它只根据非空白范围内的值进行过滤吗？

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

1 个解决方案

#1

Your code is going to be slow on many, many counts. Have a read of my blogpost on this subject if you're interested in learning about the bottlenecks to avoid when filtering PivotTables.

你的代码在许多方面会很慢。如果您有兴趣了解在过滤数据透视表时要避免的瓶颈，请阅读我关于此主题的博文。

The below code should get you started. If you have any questions, just holler.

以下代码可以帮助您入门。如果您有任何疑问，请大声说出来。

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

#1