Cutting Down Repetitive code to Avoid "Procedure Too Large" error

2
votes

I currently have some VBA code that essentially replaces a Filter Field in a PivotTable, but because the current excel spreadsheet has hundreds of PivotTables, I'm reaching to a point where the VBA doesn't work with Procedure too large.

Problem is I don't know how to decrease the repetition - any assistance would be certainly appreciated.

Code below: 

 Private Sub Worksheet_Change(ByVal Target As Range)
        If Intersect(Target, Range("P6:P7")) Is Nothing Then Exit Sub

        Dim pt As PivotTable
        Dim Field As PivotField
        Dim NewCat As String

        Set pt = Worksheets("Pivot Booking").PivotTables("PivotTable8")
        Set Field = pt.PivotFields("Company Code")
        NewCat = Worksheets("Trending&Benchmarking").Range("P6").Value

        With pt
             Field.ClearAllFilters
             Field.CurrentPage = NewCat


        End With

        Set pt = Worksheets("Pivot Booking").PivotTables("PivotTable6")
        Set Field = pt.PivotFields("Company Code")
        NewCat = Worksheets("Trending&Benchmarking").Range("P6").Value

        With pt
             Field.ClearAllFilters
             Field.CurrentPage = NewCat


        End With

        Set pt = Worksheets("Pivot Booking").PivotTables("PivotTable20")
        Set Field = pt.PivotFields("Company Code")
        NewCat = Worksheets("Trending&Benchmarking").Range("P6").Value

        With pt
             Field.ClearAllFilters
             Field.CurrentPage = NewCat


        End With

        Set pt = Worksheets("Pivot Booking").PivotTables("PivotTable7")
        Set Field = pt.PivotFields("Company Code")
        NewCat = Worksheets("Trending&Benchmarking").Range("P6").Value

        With pt
             Field.ClearAllFilters
             Field.CurrentPage = NewCat


     'Keeps on repeating for about 200 more PivotTables in Various Sheets

 End With

 End Sub
2
excelvba
Use a slicer for the company code!!! Or failing that at least Use foreach loop to loop through all pivot tables in the workbook setting the value to cell p6 – Steven Martin

2 Answers

1
votes

If you want to change all the pivot tables on that sheet:

Private Sub Worksheet_Change(ByVal Target As Range)

        If Intersect(Target, Range("P6:P7")) Is Nothing Then Exit Sub

        Dim pt As PivotTable, NewCat As String, s

        NewCat = Worksheets("Trending&Benchmarking").Range("P6").Value

        For Each s In Array("Pivot Booking", "Pivot Transaction", _
                                             "Pivot Level Segment")

            For Each pt In Worksheets(s).PivotTables
                With pt.PivotFields("Company Code")
                    .ClearAllFilters
                    .CurrentPage = NewCat
                End With
            Next pt

        Next s

End Sub
0
votes

Thank you all - the complete code that has worked is as per below: 

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("P6:P7")) Is Nothing Then Exit Sub

    Application.EnableEvents = False

    On Error GoTo ErrorHandler

    Dim pt As PivotTable, NewCat As String, s

    NewCat = Worksheets("Trending&Benchmarking").Range("P6").Value

    For Each s In Array("Pivot Booking", "Pivot Transaction", "Pivot Level Segment", "Pivot YoY TransactionGraph")

        For Each pt In Worksheets(s).PivotTables
            With pt.PivotFields("Company Code")
                .ClearAllFilters
                .CurrentPage = NewCat
            End With
        Next pt

    Next s

ErrorHandler:

  Debug.Print Err.Number & vbNewLine & Err.Description
  Resume ErrorExit

ErrorExit:

  Application.EnableEvents = True

   Exit Sub


End Sub