Question

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

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

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

1 个答案: