VBA 连接切片器(寻求代码改进)

VBA to connect slicers (looking for improvements to code)

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

我添加了 .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

上找到的原始代码

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

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

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

  2. 确保每个从数据透视表的 'Select Multiple Items' 复选框是 deselected
  3. 为每个从站添加一个切片器。同样,这些将在看不见的地方:
  4. 将每个切片器连接到您必须开始的实际数据透视表。 (即使用报表连接框将每个隐藏的切片器连接到其可见的对应数据透视表。

现在这就是聪明的 hack 出现的地方:我们将连接到 PivotTable1 Slave PivotTable 的切片器移动到主 sheet 中,以便用户可以单击在上面。当他们 select 一个项目使用它时,它会为那个 PivotTable1 Slave 数据透视表生成一个 PivotTable_Update 事件,我们会密切关注它。然后我们设置其他从属数据透视表的 .PageField 以匹配 PivotTable1 从属数据透视表 的 .PageField。然后更多的魔法发生了:由于我们之前设置的隐藏切片器,那些从页面字段中的单个 selection 被复制到主数据透视表中。不需要 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

其中有一些代码可确保用户一次 select 切片器中的项目不能超过一项。

但是如果您希望用户能够 select 多个 项目怎么办?

如果您希望用户能够 select 多个项目,事情就会变得非常复杂。对于初学者,您需要将每个 PivotTable 的 ManualUpdate 属性 设置为 TRUE,这样它们就不会在每次 PivotItems 更改时刷新。即便如此,如果其中有 20,000 个项目,仅同步一个数据透视表可能需要几分钟。我在下面的 link 中有一个很好的 post,我建议您阅读,它显示了在遍历大量枢轴项目: 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/ 的 post 了解更多信息。

我正处于发布一个商业插件的最后阶段,该插件可以闪电般地完成很多这样的事情,但发布至少还有一个月的时间。

我不确定我做错了什么。我在下面发布了我的代码,我没有遇到任何错误,只是没有更新任何其他 slicers/fields。第一次测试时,部门切片器更新了所有表格一次,但随后不会清除过滤器或允许其他选择,至于月份切片器,我根本没有让它工作。我是否可能需要复制每个项目以便单独识别?如 Dim sCurrentPage As StringDim 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