Ускорение цикла слайсера в VBA

Я пытаюсь отсортировать сводную таблицу на основе некоторых значений True/False на другой вкладке. Я читал, что самый простой способ сделать это - слайсер. Код выполняется успешно, но для выполнения сортировки 230 элементов SlicerItem требуется около 45 секунд. Есть мысли как ускорить?

Вот мой код:

Sub CategoryMacro()
'Runs through Pivot Slicer and selects items from pivot table that meet certain certain TRUE/FALSE on MacroHelper

Dim wb As Workbook
Dim ws1, ws2 As Worksheet
Dim kpicat As String

'Speed Up
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set wb = ThisWorkbook
Set ws1 = wb.Sheets("MacroHelper")
Set ws2 = wb.Sheets("Visual")

'Prep with some clean-up
ws2.Activate
ActiveWorkbook.SlicerCaches("Slicer_PRODNAME").ClearManualFilter

'Toggles off products with decreasing margin
For i = 2 To 230
    Let kpicat = ws1.Range("A" & i).Value
    If ws1.Range("D" & i).Value = 0 Then ActiveWorkbook.SlicerCaches("Slicer_PRODNAME").SlicerItems(kpicat).Selected = False
Next i

'Un-Speed Up
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Я использовал вариант этого кода ReDim (из здесь из ответа Криса) очень успешно работает с огромными наборами данных, но я не уверен, что его можно применить здесь. Если это возможно, я не уверен, как бы я его применил.

Sub GetRows()
    Dim valMatch As String
    Dim rData As Range
    Dim a() As Long, z As Variant
    Dim x As Long, i As Long
    Dim sCompare As String

    Set rData = Range("A1:A50000")
    z = rData
    ReDim a(1 To UBound(z, 1))
    x = 1
    sCompare = "aa"
    For i = 1 To UBound(z)
        If z(i, 1) = sCompare Then a(x) = i: x = x + 1
    Next
    ReDim Preserve a(1 To x - 1)    
End Sub