Update Slicers with VBA is slow for multiple sets of slicers.

[jrallen82]

I was able to Frankenstein a VBA code listed on the contextures website to function with two sets of slicers, but now the sheet is slow to react. I think the issue is becuase I have everything in one macro and don't know how to split them and have them work correctly. I don't know enough about VBA to fix the slow running issue and don't know if or how I can get two separate macros to run correctly. Below is the original code and my Frankenstein code. Please help me make the sheet run faster.


Original from Contextures w/ my slicer names:
Private Sub Worksheet_PivotTableUpdate _
(ByVal Target As PivotTable)
Dim wb As Workbook
Dim scShort As SlicerCache
Dim scLong As SlicerCache
Dim siShort As SlicerItem
Dim siLong As SlicerItem

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

Set wb = ThisWorkbook
Set scShort = wb.SlicerCaches("Slice_Work_center1")
Set scLong = wb.SlicerCaches("Slicer_Work_center")

scLong.ClearManualFilter

For Each siLong In scLong.VisibleSlicerItems
Set siLong = scLong.SlicerItems(siLong.Name)
Set siShort = Nothing
On Error Resume Next
Set siShort = scShort.SlicerItems(siLong.Name)
On Error GoTo errHandler
If Not siShort Is Nothing Then
If siShort.Selected = True Then
siLong.Selected = True
ElseIf siShort.Selected = False Then
siLong.Selected = False
End If
Else
siLong.Selected = False
End If
Next siLong

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

errHandler:
MsgBox "Could not update pivot table"
Resume exitHandler

End Sub

Mine w/ two sets of slices that is slow:

rivate Sub Worksheet_PivotTableUpdate _
(ByVal Target As PivotTable)
Dim wb As Workbook
Dim scShort As SlicerCache
Dim scLong As SlicerCache
Dim siShort As SlicerItem
Dim siLong As SlicerItem
Dim scShorta As SlicerCache
Dim scLonga As SlicerCache
Dim siShorta As SlicerItem
Dim siLonga As SlicerItem


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


Set wb = ThisWorkbook
Set scShort = wb.SlicerCaches("Slicer_Work_center1")
Set scLong = wb.SlicerCaches("Slicer_Work_center")


scLong.ClearManualFilter


For Each siLong In scLong.VisibleSlicerItems
Set siLong = scLong.SlicerItems(siLong.Name)
Set siShort = Nothing
On Error Resume Next
Set siShort = scShort.SlicerItems(siLong.Name)
On Error GoTo errHandler
If Not siShort Is Nothing Then
If siShort.Selected = True Then
siLong.Selected = True
ElseIf siShort.Selected = False Then
siLong.Selected = False
End If
Else
siLong.Selected = False
End If
Next siLong

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


Set scShorta = wb.SlicerCaches("Slicer_Week_Count1")
Set scLonga = wb.SlicerCaches("Slicer_Week_Count")


scLonga.ClearManualFilter


For Each siLonga In scLonga.VisibleSlicerItems
Set siLonga = scLonga.SlicerItems(siLonga.Name)
Set siShorta = Nothing
On Error Resume Next
Set siShorta = scShorta.SlicerItems(siLonga.Name)
On Error GoTo errHandler
If Not siShorta Is Nothing Then
If siShorta.Selected = True Then
siLonga.Selected = True
ElseIf siShorta.Selected = False Then
siLonga.Selected = False
End If
Else
siLonga.Selected = False
End If
Next siLonga


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


errHandler:
MsgBox "Could not update pivot table"
Resume exitHandler


End Sub