excel - 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上找到的原始代码

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

原始查询链接：

Answer 1

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

1. 在看不见的地方为每个主数据透视表设置一个从数据透视表，并将每个主数据透视表中感兴趣的字段作为一个 PageField，如下所示：

   

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

现在这就是聪明的技巧的用武之地：我们将连接到PivotTable1 从属数据透视表的切片器移动到主工作表中，以便用户可以单击它。当他们使用它选择一个项目时，它会为该PivotTable1 从属数据透视表生成一个 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