如何使用切片器加速此 VBA 代码?

How to speed up this VBA code with slicers?

我有一个包含七个表格(tbl_1、tbl_2 ...tbl_7)的电子表格,每个表格都由自己的切片器控制。每个切片器都有六个按钮(10、20、30、40、50、60),代表团队代码。我使用下面的代码在每个切片器上 select 一个团队,然后为每个团队/切片器设置创建一个 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

假设这些切片器正在切片数据透视表,试试下面的代码。它可能有助于加快速度,具体取决于数据透视表的大小。

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

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

  1. 禁用计算:

    Application.ScreenUpdating = False
    With Application
    .EnableEvents = False
    .Calculation = xlCalculationManual
    End With
    
  2. 键入代码以删除切片器连接....示例:

    ActiveWorkbook.SlicerCaches("Slicer_Area").PivotTables.RemovePivotTable ( _
        ActiveSheet.PivotTables("PivotDatosGraficoAbsoluto"))
    
  3. 将切片器值设置为 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
    
  4. 进行切片器连接.. 示例:

    ActiveWorkbook.SlicerCaches("Slicer_Area").PivotTables.AddPivotTable ( _
         ActiveSheet.PivotTables("PivotDatosGraficoAbsoluto"))
    
  5. 启用事件:

    With Application
    
      .EnableEvents = True
    
      .Calculation = xlCalculationAutomatic
    

    结尾为

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