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

我目前有一些VBA代码实质上取代了数据透视表中的filter字段，但是由于当前的Excel电子表格有数百个数据透视表，因此我要深入到VBA与Procedure不能一起工作的地步。

问题是我不知道如何减less重复 – 任何援助肯定会受到赞赏。

代码如下：

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