excel - VBA 连接切片器(寻找代码改进)

Question

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

我已添加 .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 的一个怪癖。这是一个示例，其中我同步了位于不同缓存中的三个不同数据透视表。

为每个主数据透视表设置一个从数据透视表
看不见的地方，把感兴趣的领域放在每个
它们作为 PageField，如下所示:

确保为每个从属数据透视表取消选中“选择多个项目”复选框:

为每个奴隶添加一个切片器。同样，这些将是看不见的地方:

将每个切片器连接到您必须开始使用的实际数据透视表。 (即使用报告连接框将每个隐藏的切片器连接到它的可见对应数据透视表。

现在这就是聪明的技巧的用武之地:我们将连接到 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/了解更多信息。

我正处于发布商业插件的最后阶段，该插件可以快速完成很多此类工作，但发布至少还有一个月的时间。