连接切片程序的VBA (寻找代码的改进)
我终于找到了一段代码，它可以在透视表更新中将具有不同缓存的切片器连接起来。基本上，当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在构图上找到的原始代码
像往常一样感谢你的建议。
回答 2
Stack Overflow用户
发布于 2016-09-20 22:02:58
如果您只希望用户一次只选择一个项，那么您可以通过使用以下技巧快速完成这一操作，该技巧利用了PageFields的一个特殊特性。下面是一个示例，其中我同步了位于不同缓存上的三个不同的PivotTables。
- 在看不到的地方为每个主PivotTable设置一个从PivotTables，并将感兴趣的字段设置为PageField，如下所示：
- 确保取消了对每个从PivotTables的“选择多个项”复选框：
- 在每一个奴隶上加一个剪刀。再一次，这些将是一个看不见的地方：
- 将每个切片器连接到实际的PivotTables。(即使用报表连接框将每个隐藏的Slicer连接到其可见的对应PivotTable。
现在，聪明的黑客出现了:我们将连接到PivotTable1从PivotTable的Slicer移动到主表中，这样用户就可以点击它。当他们使用它选择一个项目时，它会为那个PivotTable_Update从PivotTable生成一个PivotTable1事件，我们会密切关注这个事件。然后，我们将其他从.PageField的PivotTables设置为与PivotTable1从PivotTable的.PageField匹配。然后发生了更多的魔术:那些从PageFields中的单个选择被复制到主PivotTables中，这要归功于我们早些时候设置的隐藏切片器。不需要VBA。不需要缓慢的迭代。只是闪电般的快速同步。
以下是整个设置的外观：
即使您想要筛选的字段在任何一个枢轴中都不可见，...and也会工作：
以下是实现这一目标的代码：
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。即使如此，如果PivotTable中有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/上的文章，了解更多关于这方面的信息。
我正处于发布商业加载项的最后阶段，它能以闪电般的速度完成大量的工作，但至少还有一个月的时间。
Stack Overflow用户
发布于 2016-09-23 12:47:51
我不知道我在做什么不对。我在下面发布了我的代码，我没有碰到任何错误，它只是没有更新任何其他切片/字段。在第一次测试时，部门切片器更新了所有的表一次，但之后不清除过滤器或允许另一个选择，就月切片器而言，我根本没有让它工作。我是否需要复制每一项以使其可以单独识别？就像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 Subhttps://stackoverflow.com/questions/39599449
复制相似问题
腾讯云开发者
