VBA连接切片器(寻找对代码的改进) [英] VBA to connect slicers (looking for improvements to code)

问题描述

我最终找到了一个代码，该代码将在数据透视表更新时将切片器与不同的缓存连接起来.基本上，当slicer1的值更改时，它将更改slicer2以匹配slicer1，从而更新连接到第二个slicer的所有数据透视表.

I finally found a code that will connect slicers with different caches on pivot table update. Basically when the value of slicer1 changes, it will change slicer2 to match slicer1 thus updating any pivot table connected to the second slicer.

我添加了.Application.ScreenUpdating和.Application.EnableEvents试图加快宏的速度，但是它仍然很滞后，导致Excel无法响应.

I've added .Application.ScreenUpdating and .Application.EnableEvents in an attempt to speed up the macro but it's still laggy and causes Excel to become unresponsive.

是否有更直接的编码方法，或者这里是否存在任何潜在的易失行，导致Excel炸了脑筋?

Is there a more direct way of coding this or are there any potentially volatile lines in here causing Excel to fry it's brain?

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

在上下文

原始代码

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

Thanks for any advice as always.

链接到原始查询:

推荐答案

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

If you only want the user to select just one item at a time, you can do this very quickly by using the following trick that leverages off a quirk to do with PageFields. Here's an example where I sync three different PivotTables that are on different caches.

1. 为每个主数据透视表设置一个从数据透视表 看不见的地方，并将感兴趣的领域放在每个 它们作为PageField，例如:

1. Set up a slave PivotTable for each of the master PivotTables somewhere out of sight, and put the field of interest in each of them as a PageField, like this:

现在这是聪明的技巧出现的地方:我们将连接到 PivotTable1 Slave 数据透视表的Slicer移到主表中，以便用户单击它.当他们使用某个项目选择一个项目时，它会为该 PivotTable1从属数据透视表生成一个PivotTable_Update事件，我们会密切注意.然后，我们将其他从属数据透视表的.PageField设置为与 PivotTable1从属数据透视表的.PageField匹配.然后，更多的魔术发生了:由于我们之前设置的那些隐藏的Slicer，这些从属PageFields中的单个选择被复制到了主PivotTables中.无需VBA.无需慢速迭代.只是闪电般的快速同步.

Now this is where the clever hack comes in: We move the Slicer that is connected to the PivotTable1 Slave PivotTable into the main sheet so the user can click on it. When they select an item using it, it generates a PivotTable_Update event for that PivotTable1 Slave PivotTable, which we keep an eye out for. And then we set the .PageField of those other slave PivotTables to match the .PageField of the PivotTable1 Slave PivotTable. And then more magic happens: that single selection in those slave PageFields gets replicated in the master PivotTables thanks to those hidden Slicers we set up earlier. No VBA neccessary. No slow iteration necessary. Just lightning fast syncing.

这是整个设置的外观:

Here's how the entire setup looks:

...，即使您要过滤的字段在任何枢轴上均不可见，这也将起作用:

...and this will work even if the field you want to filter on isn't visible in any of your pivots:

以下是实现此目的的代码:

Here's the code that achieves this:

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

其中包含一些代码，以确保用户一次不能在切片器中选择多个项目.

There's a bit of code in there to ensure that the user can't select more than one item in the slicer at a time.

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

But what if you want the User to be able to select multiple items?

如果您希望用户能够选择多个项目，事情就会变得越来越复杂.对于初学者，您需要将每个PivotTable的ManualUpdate属性设置为TRUE，以便它们不会在每次PivotItems更改时刷新.即使这样，如果其中有20,000个项目，也可能只需要花几分钟就可以同步一个数据透视表.我建议您阅读以下链接，在此上有一篇不错的文章，该文章显示了遍历大量PivotItems时执行不同操作所需的时间: http://dailydoseofexcel.com/archives /2013/11/14/filtering-pivots-based-on-external-ranges/

If you want the user to be able to select multiple items, things become way, way more complicated. For starters, you need to set each PivotTable's ManualUpdate property to TRUE so that they don't refresh ater each and every PivotItems changes. And even then, it can take minutes to sync just one PivotTable if it has say 20,000 items in it. I've got a good post on this at the following link that I'd recommend you read, that shows just how long it takes to perform different actions when it comes to iterate through a large number of 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/以获得更多信息.

Even then, you have a lot of other challenges to overcome depending on what you're doing. Slicers seem to really slow things down, for starters. Read my post at http://dailydoseofexcel.com/archives/2015/11/17/filtering-pivottables-with-vba-deselect-slicers-first/ for more on this.

我正处于发布商业插件的最后阶段，该插件可以像闪电般快速地完成很多任务，但是发布至少需要一个月的时间.

I'm in the final stages of launching a commercial addin that does a lot of this stuff lightning fast, but launch is at least a month away.

这篇关于VBA连接切片器(寻找对代码的改进)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！