"プロシージャが大きすぎる"エラーを回避するための反復コードの省略

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