Question

我目前有一些VBA代码基本上取代了数据透视表中的过滤器字段，但由于当前的Excel电子表格有数百个数据透视表，我已经达到了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

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

2 个答案: