VBA 连接切片器（寻找代码改进）

Question

我终于找到了一个代码，可以在数据透视表更新时将切片器与不同的缓存连接起来。基本上，当 slicer1 的值发生变化时，它会更改 slicer2 以匹配 slicer1 从而更新连接到第二个 slicer 的任何数据透视表。

我已添加 .Application.ScreenUpdating 和 .Application.EnableEvents 以尝试加速宏，但它仍然滞后并导致 Excel 无响应。

是否有更直接的编码方式，或者这里是否有任何潜在的不稳定行导致 Excel 烧毁它的大脑？

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

在Contextures找到的原始代码

一如既往地感谢您的任何建议。

link to original inquiry:

Answer 1

如果您只希望用户一次只选择一个项目，您可以使用以下技巧快速完成此操作，该技巧利用 PageFields 的一个怪癖。这是一个示例，其中我同步了位于不同缓存中的三个不同数据透视表。

1. 为每个主数据透视表设置一个从数据透视表 看不见的地方，把感兴趣的领域放在每个 它们作为一个 PageField，像这样：

2. 确保取消选中每个从属数据透视表的“选择多个项目”复选框：
3. 为每个从属设备添加一个切片器。同样，这些将是看不见的地方：
4. 将每个切片器连接到您必须开始使用的实际数据透视表。 （即使用报告连接框将每个隐藏的切片器连接到它的可见对应数据透视表。

现在这就是聪明的 hack 的用武之地：我们将连接到 PivotTable1 Slave PivotTable 的 Slicer 移动到主工作表中，以便用户可以单击它。当他们使用它选择一个项目时，它会为该 PivotTable1 Slave PivotTable 生成一个 PivotTable_Update 事件，我们会密切关注该事件。然后我们将其他从数据透视表的 .PageField 设置为与 PivotTable1 从数据透视表的 .PageField 相匹配。然后更神奇的事情发生了：由于我们之前设置的隐藏切片器，这些从属 PageFields 中的单个选择被复制到主数据透视表中。不需要 VBA。不需要缓慢的迭代。只是闪电般的快速同步。

整个设置如下所示：

...即使您要过滤的字段在您的任何数据透视表中都不可见，这也将起作用：

这是实现此目的的代码：

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

其中有一些代码可确保用户一次不能在切片器中选择多个项目。

但如果您希望用户能够选择多个项怎么办？

如果您希望用户能够选择多个项目，事情就会变得更加复杂。对于初学者，您需要将每个数据透视表的 ManualUpdate 属性设置为 TRUE，以便它们不会在每次 PivotItems 更改时刷新。即便如此，如果其中有 20,000 个项目，仅同步一个数据透视表可能需要几分钟时间。我建议您阅读以下链接中的一篇很好的帖子，它显示了在迭代大量 PivotItems 时执行不同操作需要多长时间： http://dailydoseofexcel.com/archives/2013/11/14/filtering-pivots-based-on-external-ranges/

即便如此，您还有很多其他挑战需要克服，具体取决于您正在做什么。对于初学者来说，切片机似乎真的减慢了速度。阅读我在http://dailydoseofexcel.com/archives/2015/11/17/filtering-pivottables-with-vba-deselect-slicers-first/ 的帖子以了解更多信息。

我正处于发布商业插件的最后阶段，该插件可以闪电般快速地完成大量此类工作，但至少要一个月后才能发布。

Answer 2

我不确定我做错了什么。我在下面发布了我的代码，我没有遇到任何错误，只是没有更新任何其他切片器/字段。在第一次测试时，部门切片器更新了所有表一次，但不会清除过滤器或允许其他选择，就月份切片器而言，我根本没有让它工作。我是否可能需要复制每个项目以便单独识别？如Dim sCurrentPage As String 和Dim sCurrentPage2 As String。非常感谢您在这方面的持续帮助，我以前在处理电子表格时从不希望周末来得如此糟糕。

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