如何优化在25个工作表上运行缓慢的VBA代码？

优化后的代码 #

Sub Obracun_place_OLP_NEAKTIVNO()
    Dim wsPoduzece As Worksheet
    Dim wsNeto As Worksheet
    Dim wsSpisak As Worksheet
    Dim tblNeto As ListObject
    Dim lastRowGV As Long, lastRowE As Long, lastRowPoduzece As Long
    Dim calcMode As XlCalculation
    
    ' 保存原计算模式，后续恢复
    calcMode = Application.Calculation
    ' 关闭影响速度的Excel功能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 提前定义工作表和表格对象，避免重复查找
    Set wsPoduzece = ThisWorkbook.Worksheets("PODUZEĆE_PLAĆA")
    Set wsNeto = ThisWorkbook.Worksheets("Neto plaća")
    Set wsSpisak = ThisWorkbook.Worksheets("PLAĆA_SPISAK")
    Set tblNeto = wsNeto.ListObjects("Tablica_Upit_iz_MS_Access_Database_14")
    
    Call Refresh_neto_TM
    
    ' 清理目标区域内容，无需Select
    lastRowPoduzece = wsPoduzece.Range("B7").End(xlDown).Row
    wsPoduzece.Range("B7:H" & lastRowPoduzece).ClearContents
    
    ' 应用筛选，直接操作表格对象
    With tblNeto.Range
        .AutoFilter Field:=204, Criteria1:=wsNeto.Range("A2").Value
        .AutoFilter Field:=207, Criteria1:="<>"
    End With
    
    ' 复制数据：直接赋值替代Copy/Paste，速度更快
    lastRowGV = wsNeto.Range("GV11").End(xlDown).Row
    wsPoduzece.Range("B6:F" & (6 + lastRowGV - 11)).Value = wsNeto.Range("GV11:GZ" & lastRowGV).Value
    
    lastRowE = wsNeto.Range("E11").End(xlDown).Row
    wsPoduzece.Range("G6:H" & (6 + lastRowE - 11)).Value = wsNeto.Range("E11:F" & lastRowE).Value
    
    ' 自动列宽
    wsPoduzece.Columns("B:H").EntireColumn.AutoFit
    
    ' 清除筛选
    tblNeto.AutoFilter.ShowAllData
    
    ' 设置公式，无需Select
    wsPoduzece.Range("B5").FormulaR1C1 = "=COUNTIF((R[2]C:R[100]C),R[-4]C[-1])"
    wsPoduzece.Range("E5:F5").FormulaR1C1 = "=SUM(R[2]C:R[100]C)"
    
    ' 排序操作，直接引用工作表
    lastRowPoduzece = wsPoduzece.Range("B6").End(xlDown).Row
    With wsPoduzece.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsPoduzece.Range("C7:C" & lastRowPoduzece), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsPoduzece.Range("B6:H" & lastRowPoduzece)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 清除单元格背景，无需Select
    wsPoduzece.Range("B7:H" & lastRowPoduzece).Interior.Pattern = xlNone
    
    ' 应用筛选到PLAĆA_SPISAK
    wsSpisak.Range("$C$10:$G$60").AutoFilter Field:=1, Criteria1:"<>"
    
    ' 恢复原Excel设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = calcMode
    
    ' 最后定位到指定工作表（保留原需求）
    ThisWorkbook.Worksheets("2001").Activate
    ThisWorkbook.Worksheets("2001").Range("A1").Select
End Sub

核心优化措施 #

• 彻底移除所有Select/Activate操作：这是VBA提速最关键的一步，选择和激活工作表/单元格会触发界面刷新，极大拖慢速度，直接通过对象引用操作数据。
• 关闭额外Excel自动功能：除了ScreenUpdating，还关闭EnableEvents（避免触发不必要的事件宏）并将计算模式设为手动，操作完成后再恢复原设置。
• 提前定义对象：一次性获取工作表、列表对象的引用，避免代码中重复查找这些对象，减少系统开销。
• 用直接赋值替代Copy/Paste：Range.Value = Range.Value的速度远快于复制粘贴，跳过剪贴板操作，减少内存占用。
• 批量操作数据：先获取最后行号，一次性处理整段数据区域，避免多次逐行操作。
• 简化筛选清除：使用ShowAllData一次性清除所有筛选，替代多次单独清除字段筛选的冗余操作。

内容的提问来源于stack exchange，提问作者Filip Mišić