Как ускорить этот код VBA с помощью slicers?

Question

У меня есть таблица с семью таблицами (tbl_1, tbl_2 ... tbl_7), каждая из которых управляется собственным слайсером. Каждый слайсер имеет шесть кнопок (10, 20, 30, 40, 50, 60), относящихся к командам. Я использую код ниже, чтобы выбрать одну команду на каждом слайсере, а затем создать PDF-файл для каждой настройки команды/slicer. На данный момент код занимает от 5 до 7 минут для запуска. Буду признателен за любую оказанную помощь.

Sub SlicerTeam() 
Dim wb As Workbook 
Dim sc As SlicerCache 
Dim si As SlicerItem 

On Error GoTo errHandler 
Application.ScreenUpdating = False 
Application.EnableEvents = False 

Set wb = ThisWorkbook 

For x = 1 To 6 
    For i = 1 To 7 
    Set sc = wb.SlicerCaches("tbl_" & i) 
     sc.ClearAllFilters 
     For Each si In sc.VisibleSlicerItems 
      Set si = sc.SlicerItems(si.Name) 
       If Not si Is Nothing Then 
        If si.Name = x * 10 Then 
         si.Selected = True 
        Else 
         si.Selected = False 
        End If 
       Else 
        si.Selected = False 
       End If 
     Next si 

    Next i 
Call PDFCreate 
Next x 

exitHandler: 
Application.ScreenUpdating = True 
Application.EnableEvents = True 
Exit Sub 

errHandler: 
MsgBox ("Error in updating slicer filters.") 
Resume exitHandler 

End Sub 

Answer 1

Предполагая, что эти слайсеры разрезают сводные таблицы, попробуйте приведенный ниже код. Это может помочь ускорить процесс, в зависимости от того, насколько велики ваши сводные таблицы.

Sub SlicerTeam() 
Dim wb As Workbook 
Dim sc As SlicerCache 
Dim si As SlicerItem 

dim pt as PivotTable 

On Error GoTo errHandler 
Application.ScreenUpdating = False 
Application.EnableEvents = False 

Set wb = ThisWorkbook 

For Each pt in wb.PivotTables 
    pt.ManualUpdate = True 
Next 

For x = 1 To 6 
    For i = 1 To 7 
    Set sc = wb.SlicerCaches("tbl_" & i) 
     sc.ClearAllFilters 
     For Each si In sc.VisibleSlicerItems 
      Set si = sc.SlicerItems(si.Name) 
       If Not si Is Nothing Then 
        If si.Name = x * 10 Then 
         si.Selected = True 
        Else 
         si.Selected = False 
        End If 
       Else 
        si.Selected = False 
       End If 
     Next si 

    Next i 

    For Each pt in wb.PivotTables 
     pt.ManualUpdate = True 
    Next 


    Call PDFCreate 
Next x 

exitHandler: 
Application.ScreenUpdating = True 
Application.EnableEvents = True 
Exit Sub 

errHandler: 
MsgBox ("Error in updating slicer filters.") 
Resume exitHandler 

End Sub