vba - 如何使用切片器加速此 VBA 代码？

Question

我有一个包含七个表（tbl_1、tbl_2 ...tbl_7）的电子表格，每个表都由自己的切片器控制。每个切片器有 6 个按钮（10、20、30、40、50、60）参考团队代码。我使用下面的代码在每个切片器上选择一个团队，然后为每个团队/切片器设置创建一个 PDF。截至目前，代码需要 5-7 分钟才能运行。任何帮助深表感谢。

Sub SlicerTeam()
Dim wb As Workbook
Dim sc As SlicerCache
Dim si As SlicerItem

On Error GoTo errHandler
Application.ScreenUpdating = False
Application.EnableEvents = False

Set wb = ThisWorkbook

For x = 1 To 6
    For i = 1 To 7
    Set sc = wb.SlicerCaches("tbl_" & i)
        sc.ClearAllFilters
        For Each si In sc.VisibleSlicerItems
            Set si = sc.SlicerItems(si.Name)
                If Not si Is Nothing Then
                    If si.Name = x * 10 Then
                        si.Selected = True
                    Else
                        si.Selected = False
                    End If
                Else
                    si.Selected = False
                End If
        Next si

    Next i
Call PDFCreate
Next x

exitHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub

errHandler:
MsgBox ("Error in updating slicer filters.")
Resume exitHandler

End Sub

score 1 · Accepted Answer

假设这些切片器正在切片数据透视表，请尝试以下代码。它可能有助于加快速度，具体取决于您的数据透视表有多大。

Sub SlicerTeam()
Dim wb As Workbook
Dim sc As SlicerCache
Dim si As SlicerItem

dim pt as PivotTable

On Error GoTo errHandler
Application.ScreenUpdating = False
Application.EnableEvents = False

Set wb = ThisWorkbook

For Each pt in wb.PivotTables
    pt.ManualUpdate = True
Next

For x = 1 To 6
    For i = 1 To 7
    Set sc = wb.SlicerCaches("tbl_" & i)
        sc.ClearAllFilters
        For Each si In sc.VisibleSlicerItems
            Set si = sc.SlicerItems(si.Name)
                If Not si Is Nothing Then
                    If si.Name = x * 10 Then
                        si.Selected = True
                    Else
                        si.Selected = False
                    End If
                Else
                    si.Selected = False
                End If
        Next si

    Next i

    For Each pt in wb.PivotTables
        pt.ManualUpdate = True
    Next


    Call PDFCreate
Next x

exitHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub

errHandler:
MsgBox ("Error in updating slicer filters.")
Resume exitHandler

End Sub

score 0 · Accepted Answer

经过几次试验..发现这是最好的选择。

禁用计算：

Application.ScreenUpdating = False
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
End With

键入代码以删除切片器连接.... 示例：

ActiveWorkbook.SlicerCaches("Slicer_Area").PivotTables.RemovePivotTable ( _
    ActiveSheet.PivotTables("PivotDatosGraficoAbsoluto"))

将切片器值设置为 true，将其他值设置为 false... 示例：

Set MySlicerCache = ActiveWorkbook.SlicerCaches("Slicer_Area")
            For i = 1 To MySlicerCache.SlicerItems.Count
                With MySlicerCache.SlicerItems(i)
                    If .Name = "Comercial GJ" Then
                        .Selected = True
                        'Range("E1").Value = .Name
                    Else:
                        .Selected = False
                    End If
                End With
            Next i

执行切片器连接.. 示例：

ActiveWorkbook.SlicerCaches("Slicer_Area").PivotTables.AddPivotTable ( _
     ActiveSheet.PivotTables("PivotDatosGraficoAbsoluto"))

启用事件：

With Application

  .EnableEvents = True

  .Calculation = xlCalculationAutomatic

结束于

这将节省大约 40% 的等待时间

vba - 如何使用切片器加速此 VBA 代码？

2 回答 2

Related

Reference