减少重复代码以避免“过程太大”错误

Question

我目前有一些VBA代码，它基本上取代了PivotTable中的Filter字段，但是由于当前的excel电子表格有数百个PivotTables，所以VBA的工作过程不太大。

问题是，我不知道如何减少重复-任何帮助肯定会感谢。

代码如下：

 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

Answer 1

如果您想更改该工作表上的所有枢轴表：

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

Answer 2

谢谢大家，完整的代码如下所示：

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