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，如下所示：
确保选择多个项目＆＃39;每个从属数据透视表的复选框取消选择：
为每个奴隶添加切片器。再次，这些将在某处看不见：
将每个Slicers连接到您必须开始的实际数据透视表。（即使用“报告连接”框将每个隐藏的切片器连接到它的可见对应数据透视表。

现在这是巧妙的黑客入侵的地方：我们将连接到 PivotTable1 Slave 数据透视表的切片器移动到主工作表中，以便用户可以点击它。当他们使用它选择一个项目时，它会为 PivotTable1 Slave 数据透视表生成一个PivotTable_Update事件，我们会密切关注。然后我们设置其他slave PivotTables的.PageField以匹配 PivotTable1 Slave PivotTable的.PageField。然后会发生更多魔术：由于我们之前设置的隐藏切片器，这些从属PageField中的单个选择会在主数据透视表中复制。没有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的更改。即便如此，如果只有一个数据透视表，它可能需要几分钟来同步它。我在以下链接上有一篇很好的帖子，我建议你阅读，这表明在迭代大量的PivotItem时执行不同的操作需要多长时间： 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

我不确定我做错了什么。我在下面发布了我的代码，我没有遇到任何错误，它只是不更新任何其他切片器/字段。在第一次测试时，Department切片器更新了所有表一次，但是然后不会清除过滤器或允许其他选择，就Month切片器而言，我根本没有让它工作。我是否需要复制每个项目以使其可单独识别？与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

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

2 个答案: