VBA to connect slicers (looking for improvements to code)

I finally found a code that will connect slicers with different caches on pivot table update. Basically when the value of slicer1 changes, it will change slicer2 to match slicer1 thus updating any pivot table connected to the second slicer.

I've added .Application.ScreenUpdating and .Application.EnableEvents in an attempt to speed up the macro but it's still laggy and causes Excel to become unresponsive.

Is there a more direct way of coding this or are there any potentially volatile lines in here causing Excel to fry it's brain?

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

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

Set wb = ThisWorkbook
Set scShort = wb.SlicerCaches("Slicer_Department")
Set scLong = wb.SlicerCaches("Slicer_Department2")

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
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

original code found on Contextures

Thanks for any advice as always.

link to original inquiry:

If you only want the user to select just one item at a time, you can do this very quickly by using the following trick that leverages off a quirk to do with PageFields. Here's an example where I sync three different PivotTables that are on different caches.

Set up a slave PivotTable for each of the master PivotTables somewhere out of sight, and put the field of interest in each of them as a PageField, like this:
Make sure the 'Select Multiple Items' checkbox is deselected for each of those slave PivotTables:
Add a Slicer to each of those Slaves. Again, these will be somewhere out of sight:
Connect each of those Slicers up to the actual PivotTables you had to begin with. (i.e. connect each hidden Slicer to it's visible counterpart PivotTable using the Report Connections box.

Now this is where the clever hack comes in: We move the Slicer that is connected to the PivotTable1 Slave PivotTable into the main sheet so the user can click on it. When they select an item using it, it generates a PivotTable_Update event for that PivotTable1 Slave PivotTable, which we keep an eye out for. And then we set the .PageField of those other slave PivotTables to match the .PageField of the PivotTable1 Slave PivotTable. And then more magic happens: that single selection in those slave PageFields gets replicated in the master PivotTables thanks to those hidden Slicers we set up earlier. No VBA neccessary. No slow iteration necessary. Just lightning fast syncing.

Here's how the entire setup looks:

...and this will work even if the field you want to filter on isn't visible in any of your pivots:

Here's the code that achieves this:

Option Explicit

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

Dim pt As PivotTable
Dim pf As PivotField
Dim sCurrentPage As String
Dim vItem As Variant
Dim vArray As Variant

'########################
'# Change these to suit #
'########################

Const sField As String = "Name"
vArray = Array("PivotTable2 Slave", "PivotTable3 Slave")


If Target.Name = "PivotTable1 Slave" Then
    On Error GoTo errhandler
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Find out what item they just selected
    Set pf = Target.PivotFields(sField)
    With pf
        If .EnableMultiplePageItems Then
            .ClearAllFilters
            .EnableMultiplePageItems = False
            sCurrentPage = "(All)"
        Else:
            sCurrentPage = .CurrentPage
        End If
    End With

    'Change the other slave pivots to match. Slicers will pass on those settings
    For Each vItem In vArray
        Set pt = ActiveSheet.PivotTables(vItem)
        Set pf = pt.PivotFields(sField)
        With pf
            If .CurrentPage <> sCurrentPage Then
                .ClearAllFilters
                .CurrentPage = sCurrentPage
            End If
        End With
    Next vItem

errhandler:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End If

End Sub

There's a bit of code in there to ensure that the user can't select more than one item in the slicer at a time.

But what if you want the User to be able to select multiple items?

If you want the user to be able to select multiple items, things become way, way more complicated. For starters, you need to set each PivotTable's ManualUpdate property to TRUE so that they don't refresh ater each and every PivotItems changes. And even then, it can take minutes to sync just one PivotTable if it has say 20,000 items in it. I've got a good post on this at the following link that I'd recommend you read, that shows just how long it takes to perform different actions when it comes to iterate through a large number of PivotItems: http://dailydoseofexcel.com/archives/2013/11/14/filtering-pivots-based-on-external-ranges/

Even then, you have a lot of other challenges to overcome depending on what you're doing. Slicers seem to really slow things down, for starters. Read my post at http://dailydoseofexcel.com/archives/2015/11/17/filtering-pivottables-with-vba-deselect-slicers-first/ for more on this.

I'm in the final stages of launching a commercial addin that does a lot of this stuff lightning fast, but launch is at least a month away.

I'm unsure what I'm doing incorrect. I posted my code below, I'm not hitting any errors, it's simply just not updating any of the other slicers/fields. Upon first test, the Department slicer updated all the tables once, but then would not clear the filter or allow another selection, as far as the Month slicer, I haven't gotten it to work at all. Do I perhaps need to duplicate each item so that it's separately identifiable? As in Dim sCurrentPage As String and Dim sCurrentPage2 As String. Thank you so much for your continued assistance with this, I've never wanted the weekend to come so badly while working on a spreadsheet before.

Option Explicit

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

Dim pt As PivotTable
Dim pf As PivotField
Dim sCurrentPage As String
Dim vItem As Variant
Dim vArray As Variant
Dim sField As String

'########################
'# Change these to suit #
'########################

sField = "Department"
vArray = Array("PivotTable2 Slave", "PivotTable3 Slave")


If Target.Name = "PivotTable1 Slave" Then
    On Error GoTo errhandler
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Find out what item they just selected
    Set pf = Target.PivotFields(sField)
    With pf
        If .EnableMultiplePageItems Then
            .ClearAllFilters
            .EnableMultiplePageItems = False
            sCurrentPage = "(All)"
        Else:
            sCurrentPage = .CurrentPage
        End If
    End With

    'Change the other slave pivots to match. Slicers will pass on those settings
    For Each vItem In vArray
        Set pt = ActiveSheet.PivotTables(vItem)
        Set pf = pt.PivotFields(sField)
        With pf
            If .CurrentPage <> sCurrentPage Then
                .ClearAllFilters
                .CurrentPage = sCurrentPage
            End If
        End With
    Next vItem

'########################

sField = "Month"
vArray = Array("PivotTable2 Slave2", "PivotTable3 Slave2")


If Target.Name = "PivotTable1 Slave2" Then
    On Error GoTo errhandler
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Find out what item they just selected
    Set pf = Target.PivotFields(sField)
    With pf
        If .EnableMultiplePageItems Then
            .ClearAllFilters
            .EnableMultiplePageItems = False
            sCurrentPage = "(All)"
        Else:
            sCurrentPage = .CurrentPage
        End If
    End With

    'Change the other slave pivots to match. Slicers will pass on those settings
    For Each vItem In vArray
        Set pt = ActiveSheet.PivotTables(vItem)
        Set pf = pt.PivotFields(sField)
        With pf
            If .CurrentPage <> sCurrentPage Then
                .ClearAllFilters
                .CurrentPage = sCurrentPage
            End If
        End With
    Next vItem

errhandler:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End If

End Sub

来源：https://stackoverflow.com/questions/39599449/vba-to-connect-slicers-looking-for-improvements-to-code

标签

excel-vba

pivot-table

slicers

vba

excel