使用数组 VBA 优化 Excel 数据透视表过滤器答案

【问题标题】：Optimize Excel Pivot Table Filter Using Array VBA使用数组 VBA 优化 Excel 数据透视表过滤器
【发布时间】：2015-07-14 19:54:32
【问题描述】：

我有一个用户表单，用户将在其中检查他们想要过滤一组数据透视表的所有项目。问题是我有大约 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

【问题讨论】：

循环有什么问题？或者，你为什么要优化这段代码？我怀疑真正的问题是包含 250 个选项的 40 个数据透视表。
嗨，Bryon，是的，我同意问题在于数量。当数据透视表的数量和选项的数量都受到限制时，此代码可以快速运行。虽然这可能是不可能的，但我想知道是否有一种方法可以像使用列一样用一行设置每个数据透视表的过滤器。
如果使用PivotField.VisibleItemsList 将字段指定为OLAP，则可以完成。不确定它是否更快。如果您想尝试，请使用数据透视表上的Data Model 选项。我怀疑这可能需要转换所有表格。

标签： vba excel optimization pivot-table

【解决方案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

【讨论】：