Optimize Excel Pivot Table Filter Using Array VBA

后端 未结 1 1590
滥情空心
滥情空心 2021-01-25 02:39

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

相关标签:
1条回答
  • 2021-01-25 03:10

    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
    
    0 讨论(0)
提交回复
热议问题