使用阵列VBA优化Excel数据透视表筛选器

Question

I have a userform in which a user will check all items they want a group of pivot tables filtered on. The issue is I have about 40 pivot tables and over 250 options the user can filter on. Ideally, I planned to set the pivot table filter to an array of values, but I cannot find a solution that avoids looping through the array and filter options. Please find my code below. Any optimization advice is greatly appreciated. Thank you!

Private Sub Filter_btn_Click()
Dim i As Integer
Dim n As Integer
Dim filter_num As Integer
Dim pivot_num As Integer
Dim MyArray() As String
Dim pt As PivotTable

Application.ScreenUpdating = False

Set dashboard = Sheets("Dashboard")

'Adding all selected items to array
n = 0
For i = 0 To Supplier_Listbox.ListCount - 1
    If Supplier_Listbox.Selected(i) = True Then
        ReDim Preserve MyArray(n)
        MyArray(n) = Supplier_Listbox.List(i)
        n = n + 1
    End If
Next

i = 0
For pivot_num = 1 To 41
    Set pt = dashboard.PivotTables("PivotTable" & pivot_num)
    filter_num = 0
    With pt.PivotFields("FilterItems")
        'Include first item in filter to avoid error
        .PivotItems(1).Visible = True
        ' PivotItems.Count is 270
        For i = 2 To .PivotItems.Count
            ' Attempted to make the code a little faster with first if statement. Will avoid function if all array items have been checked
            If filter_num = n Then
            .PivotItems(i).Visible = False
           ' Call to function
           ElseIf IsInArray(.PivotItems(i), MyArray) Then
                .PivotItems(i).Visible = True
                filter_num = filter_num + 1
            Else:
                .PivotItems(i).Visible = False
            End If
        Next
       'Check if first item is actually in array, if not, remove filter
       If IsInArray(.PivotItems(1), MyArray) Then
                .PivotItems(1).Visible = True
            Else:
                .PivotItems(1).Visible = False
            End If
    End With
Next

Unload Me

Application.ScreenUpdating = True

End Sub

Answer 1

I ended up filtering the original set of data based on my array and copying and pasting those filtered values to a new table on a different sheet. This new sheet became the source data for my 40 pivot tables. This change created several smaller issues, but now the code runs in <10 seconds compared to 90 seconds. Thank you to everyone that provided suggestions to this issue.

Private Sub Filter_btn_Click()
Dim i As Integer
Dim n As Integer
Dim MyArray() As String

Application.ScreenUpdating = False

Set dashboard = Sheets("Dashboard")
Set Org_data = Sheets("Original Data")
Set Filtered_Data = Sheets("Filtered Data")

'Adding all selected items in userform to array
n = 0
For i = 0 To FilterOptions_Listbox.ListCount - 1
    If FilterOptions_Listbox.Selected(i) = True Then
        ReDim Preserve MyArray(n)
        MyArray(n) = FilterOptions_Listbox.List(i)
        n = n + 1
    End If
Next

Filtered_Data.Activate
ActiveSheet.ListObjects("Table2").DataBodyRange.Select
Selection.ClearContents

'Copy values filtered on array
Org_data.Activate
Org_data.ShowAllData
With Org_data.Range("A1")
    .AutoFilter Field:=2, Criteria1:=MyArray, Operator:=xlFilterValues
End With
ActiveSheet.ListObjects("Table1").DataBodyRange.Select
Selection.Copy

'Paste filtered values
Filtered_Data.Activate
ActiveSheet.ListObjects("Table2").DataBodyRange.Select
Selection.PasteSpecial xlPasteValues

Application.CutCopyMode = False

'Refresh all pivot tables at once
ActiveWorkbook.RefreshAll
dashboard.Activate

Application.ScreenUpdating = True

Unload Me

End Sub