VBA对比新旧订单Excel工作表时循环到1000行崩溃，求代码优化

• 全流程依赖Select/Activate切表、选中单元格：每一次操作都会触发Excel界面重绘，1000次循环的界面渲染开销占总运行耗时的90%以上，极易触发内存溢出崩溃。
• 逐行触发全列Find查找：每读到新的订单行，就切到旧表选中整列执行一次查找，3000行数据对应3000次全列扫描，计算量随数据量呈平方级增长。
• 未关闭Excel运行时的额外开销：默认状态下每修改一个单元格格式，都会触发表格自动重算、格式重绘，进一步拉低运行速度。
• 列对比逻辑存在硬编码错位：代码中从第19列（S列）开始逐格比对，却写了遍历A1:P1（共16列）的循环，不仅比对的列范围完全不符合预期，还在循环里反复切表触发冗余操作。

• 运行前关闭非必要的Excel交互：在代码开头设置ScreenUpdating = False、Calculation = xlCalculationManual，搭配错误捕获机制，确保代码运行结束后自动恢复初始设置，避免Excel卡死。
• 用字典建立旧表订单索引：提前将旧表A列的订单号、对应行号存入VBA字典，循环新表时直接通过键值匹配对应旧订单行，无需逐行调用Find方法，匹配速度可提升几十倍。
• 用工作表对象引用替代选中操作：提前将新旧两个工作表赋值给对象变量，后续所有单元格读写、格式设置直接通过对象完成，全程不需要切换工作表、选中单元格，零界面交互。
• 批量设置高亮格式：将需要标记的新增行、变更单元格统一存入Range对象，通过Union方法合并区域，循环结束后一次性设置背景色，减少重复格式写入的开销。
• 修正列比对逻辑：明确需要对比的列号范围，去掉错位的列偏移计算，逐列比对同订单下的新旧单元格值，值不一致再做标记。

Private Sub CompareOrders()
    Dim wsNew As Worksheet, wsOld As Worksheet
    Dim orderDict As Object
    Dim lastRowNew As Long, lastRowOld As Long
    Dim i As Long, j As Long
    Dim highlightRow As Range, highlightCell As Range
    
    ' 关闭拖慢速度的默认设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    On Error GoTo Cleanup
    
    ' 绑定两个工作表的对象引用，全程不需要Select
    Set wsNew = ThisWorkbook.Sheets("New Sheet")
    Set wsOld = ThisWorkbook.Sheets("Old Sheet")
    
    ' 构建旧表的订单号索引字典，替代逐行Find
    Set orderDict = CreateObject("Scripting.Dictionary")
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRowOld
        orderDict(wsOld.Cells(i, "A").Value) = i
    Next i
    
    ' 遍历新表的有效数据行（按C列非空判断）
    lastRowNew = wsNew.Cells(wsNew.Rows.Count, "C").End(xlUp).Row
    For i = 2 To lastRowNew
        If wsNew.Cells(i, "C").Value <> "" Then
            Dim currentOrderID As String
            currentOrderID = wsNew.Cells(i, "A").Value
            
            ' 旧表无匹配订单，标记整行
            If Not orderDict.Exists(currentOrderID) Then
                If highlightRow Is Nothing Then
                    Set highlightRow = wsNew.Range(wsNew.Cells(i, "A"), wsNew.Cells(i, "X"))
                Else
                    Set highlightRow = Union(highlightRow, wsNew.Range(wsNew.Cells(i, "A"), wsNew.Cells(i, "X")))
                End If
            Else
                ' 有匹配订单，逐列比对需要检查的范围（原代码为第19列开始的16列）
                Dim oldMatchRow As Long
                oldMatchRow = orderDict(currentOrderID)
                For j = 19 To 34
                    If wsNew.Cells(i, j).Value <> wsOld.Cells(oldMatchRow, j - 1).Value Then
                        If highlightCell Is Nothing Then
                            Set highlightCell = wsNew.Cells(i, j)
                        Else
                            Set highlightCell = Union(highlightCell, wsNew.Cells(i, j))
                        End If
                    End If
                Next j
            End If
        End If
    Next i
    
    ' 批量应用高亮格式
    If Not highlightRow Is Nothing Then highlightRow.Interior.ColorIndex = 37
    If Not highlightCell Is Nothing Then highlightCell.Interior.ColorIndex = 37

Cleanup:
    ' 不管运行是否出错，都恢复Excel的默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then MsgBox "运行异常：" & Err.Description
End Sub

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