как ускорить выбор кода VBA слайсера

Question

надеюсь, что все хорошо.

У меня есть этот код, который делает выбор слайсера (первый элемент):

Sub test()


Dim sc As SlicerCache

Set sc = ActiveWorkbook.SlicerCaches("Slicer_book1")


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

For Each pt In sc.PivotTables
    pt.ManualUpdate = True 
Next pt

    With ActiveWorkbook.SlicerCaches("Slicer_book1")
    .ClearManualFilter
    cnt = .SlicerItems.Count
    If cnt > 1 Then
        For i = 2 To cnt
            .SlicerItems(i).Selected = False
        Next
    End If
End With

For Each pt In sc.PivotTables
    pt.ManualUpdate = False
Next pt

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

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

каким-то образом этот код работает, но он неописуемо показателен. Итак, мне было интересно, есть ли у кого-нибудь совет, как правильно ускорить это?

Спасибо и всего наилучшего.

Answer 1

Я предпочитаю использовать имя сводной таблицы, чем слайсер.

Sub test()


Dim sc As SlicerCache
Dim SIName As String
Dim pt As PivotTable, PTF As PivotField

Set sc = ActiveWorkbook.SlicerCaches("Slicer_book1")


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

For Each pt In sc.PivotTables
    pt.ManualUpdate = True 
Next pt

    With ActiveWorkbook.SlicerCaches("Slicer_book1")
    '.ClearManualFilter
    cnt = .SlicerItems.Count
    If cnt > 1 Then
        SIName  = .SlicerItems(1).Name
    End If
End With

'Pivot is the sheet name where the pivot table is located
ActiveWorkbook.Worksheets("Pivot").Activate
Set pt = ActiveWorkbook.Worksheets("Pivot").PivotTables("NameOfPivotTable")
'Book is pivot field
Set PTF = pt.PivotFields("Book")
PTF.ClearAllFilters
PTF.CurrentPage = SIName

For Each pt In sc.PivotTables
    pt.ManualUpdate = False
Next pt

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

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

End Sub

Надеюсь, эта помощь