运行缓慢的Excel VBA宏代码优化排查求助

你的宏功能正常但运行缓慢，核心问题集中在不必要的单元格选择操作、低效的循环格式化和未充分禁用Excel后台功能上，以下是具体优化点和重构后的代码：

一、核心性能瓶颈分析与改进 #

1. 移除所有Select/Selection/Activate操作 #

这是VBA性能提升的关键，每次选择都会触发Excel的界面更新逻辑，即便ScreenUpdating=False也会产生额外开销。直接通过对象引用操作单元格/工作表，避免无意义的交互。

2. 用批量条件格式替代逐单元格循环 #

原代码遍历每个单元格设置背景色，数据量大时效率极低。改用Excel内置的条件格式功能批量处理，效率可提升数倍。

3. 禁用更多Excel后台功能 #

除ScreenUpdating外，还需禁用EnableEvents（避免触发不必要的事件）和Calculation（暂时设为手动计算，完成后恢复），减少后台资源占用。

4. 优化数据复制方式 #

直接通过单元格区域赋值替代Copy/Paste，减少剪贴板操作的额外开销。

5. 减少重复操作 #

合并多次AutoFit调用，将列宽设置整合到一个With块中，减少对象访问次数。

6. 变量声明与优化 #

启用Option Explicit强制变量声明，避免隐式类型转换开销；插入星期列后将公式转为值，减少公式计算负担。

二、重构后的优化代码 #

Option Explicit '强制变量声明，避免隐性错误

Sub Preactor_Sort()
    Dim wsFull As Worksheet, wsSorted As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    
    '禁用Excel后台功能，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    '初始化工作表对象
    Set wsFull = ThisWorkbook.Sheets("FULL LIST")
    Set wsSorted = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets("MASTER"))
    wsSorted.Name = "Sorted Full"
    
    '复制数据：直接赋值替代Copy/Paste，效率更高
    lastRow = wsFull.Cells(wsFull.Rows.Count, "A").End(xlUp).Row
    Set dataRange = wsFull.Range("A8:R" & lastRow)
    wsSorted.Range("A1").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value
    
    '设置窗口缩放（仅此处保留Activate，为了窗口设置）
    wsSorted.Activate
    ActiveWindow.Zoom = 60
    
    '批量格式化单元格，无需Select
    wsSorted.Cells.FormatConditions.Delete
    With wsSorted.Cells.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With wsSorted.Cells
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    
    '列操作：直接引用列对象，避免Select/Cut/Insert的冗余操作
    wsSorted.Columns("E:E").Cut
    wsSorted.Columns("C:C").Insert Shift:=xlToRight
    wsSorted.Columns("A:C").Delete Shift:=xlToLeft
    
    wsSorted.Columns("G:H").Cut
    wsSorted.Columns("B:B").Insert Shift:=xlToRight
    wsSorted.Columns("K:L").Cut
    wsSorted.Columns("E:E").Insert Shift:=xlToRight
    
    '日期/星期处理
    With wsSorted.Columns("C:C")
        .NumberFormat = "dd/mm/yy hh:mm"
        .EntireColumn.AutoFit
    End With
    wsSorted.Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    wsSorted.Columns("C:C").NumberFormat = "General"
    
    lastRow = wsSorted.Cells.Find("*", wsSorted.Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    '插入星期公式并转为值，减少后续计算负担
    With wsSorted.Range("C2:C" & lastRow)
        .Formula = "=TEXT(D2,""ddd"")"
        .Value = .Value '公式转静态值
    End With
    wsSorted.Columns("C:C").EntireColumn.AutoFit
    
    '排序操作：直接引用目标工作表，无需依赖ActiveSheet
    With wsSorted.Sort
        .SortFields.Clear '清除原有排序规则，避免冲突
        .SortFields.Add2 Key:=wsSorted.Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
        .SortFields.Add2 Key:=wsSorted.Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
        .SetRange wsSorted.Range("A:P")
        .Header = xlYes
        .Apply
    End With
    
    '格式设置：整合列宽与字体设置，减少对象访问
    With wsSorted
        .Range("C:C,E:E").Font.Bold = True
        .Columns("B:B").ColumnWidth = 10
        .Columns("F:G").ColumnWidth = 25
        .Columns("A:A").ColumnWidth = 8
        .Columns("I:J").ColumnWidth = 5
        .Columns("L:N").ColumnWidth = 15
        .Columns("O:O").ColumnWidth = 80
        .Columns("H:H").ColumnWidth = 40
        .Columns("K:K").ColumnWidth = 6
    End With
    
    '条件格式：用Excel内置功能批量设置，替代逐单元格循环
    lastRow = wsSorted.Range("A1").End(xlDown).Row
    
    '1. 交替行颜色
    wsSorted.Cells.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
    With wsSorted.Cells.FormatConditions(wsSorted.Cells.FormatConditions.Count)
        .Interior.ColorIndex = 34
        .SetFirstPriority
    End With
    
    '2. 按操作类型高亮B列
    With wsSorted.Columns("B:B").FormatConditions
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Make"""
        .Item(.Count).Interior.ColorIndex = 35
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Discharge"""
        .Item(.Count).Interior.ColorIndex = 36
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Packing"""
        .Item(.Count).Interior.ColorIndex = 19
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Wrapping"""
        .Item(.Count).Interior.ColorIndex = 6
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Boxing"""
        .Item(.Count).Interior.ColorIndex = 44
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Oil Phase"""
        .Item(.Count).Interior.ColorIndex = 38
    End With
    
    '3. 按星期高亮C列
    With wsSorted.Columns("C:C").FormatConditions
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Mon"""
        .Item(.Count).Interior.ColorIndex = 7
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Tue"""
        .Item(.Count).Interior.ColorIndex = 4
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Wed"""
        .Item(.Count).Interior.ColorIndex = 6
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Thu"""
        .Item(.Count).Interior.ColorIndex = 45
        .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="""Fri"""
        .Item(.Count).Interior.ColorIndex = 33
    End With
    
    '表头格式设置
    With wsSorted.Range("A1:P1")
        .Interior.ColorIndex = 15
        .Font.Bold = True
    End With
    
    '打印机配置：合并With块，减少重复访问PageSetup对象
    Application.PrintCommunication = False '关闭打印通信，提升设置速度
    With wsSorted.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .PrintArea = ""
        .LeftMargin = Application.InchesToPoints(0.12)
        .RightMargin = Application.InchesToPoints(0.12)
        .TopMargin = Application.InchesToPoints(0.16)
        .BottomMargin = Application.InchesToPoints(0.16)
        .HeaderMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.12)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
    End With
    Application.PrintCommunication = True
    
    '恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

三、额外优化建议 #

• 错误处理：添加On Error GoTo语句，确保即使宏意外中断，Excel的后台设置也能正常恢复，避免影响后续操作。
• 数据范围可靠性：复制数据时，End(xlDown)可能因空行中断，建议改用lastRow = wsFull.Cells(wsFull.Rows.Count, "A").End(xlUp).Row获取最后一行，适配含空行的数据集。

内容的提问来源于stack exchange，提问作者Andy Rice