Question

我有一个userform，用户将在其中检查他们想要过滤的一组数据透视表的所有项目。问题是我有大约40个数据透视表和250多个用户可以过滤的选项。理想情况下，我计划将数据透视表过滤器设置为值数组，但我找不到避免循环遍历数组和过滤器选项的解决方案。请在下面找到我的代码。非常感谢任何优化建议。谢谢！

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

我最终根据我的数组过滤了原始数据集，并将这些过滤后的值复制并粘贴到另一张表上的新表中。这个新工作表成为我的40个数据透视表的源数据。此更改创建了几个较小的问题，但现在代码在<10秒内运行，而90秒。感谢所有为此问题提供建议的人。

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

使用阵列VBA优化Excel数据透视表过滤器

1 个答案: