优化双工作表对比删除行的VBA代码，解决运行卡顿问题

问题背景 #

现有VBA代码用于对比Sheet1与Validations两个工作表的指定列：若列值依次匹配则完成校验并标记Approve，任意环节不匹配则删除Sheet1对应行。但当前代码因频繁使用Activate切换工作表，处理2200行数据需约1分钟，甚至可能导致Excel崩溃，急需更高效的实现方案。

原代码核心问题 #

1. 频繁工作表切换：每次读写单元格都调用Activate，触发Excel界面刷新与上下文切换，是性能损耗的主要原因
2. 嵌套逐行循环：双重循环逐行对比，时间复杂度为O(n*m)，数据量增大时效率急剧下降
3. 逐行删除操作：每次删除行都会触发Excel重排，多次操作累积拖慢速度

优化方案 #

核心优化点 #

• 直接引用工作表对象，彻底摒弃Activate/Select操作
• 将工作表数据加载到内存数组，避免反复读写单元格
• 使用Dictionary预存储Validations表的校验规则，将匹配复杂度从O(n*m)降至O(n)
• 批量标记待删除行，最后一次性删除，减少Excel重排次数

优化后的代码 #

Sub OptimizedValidationCheck()
    Dim wsSheet1 As Worksheet, wsValid As Worksheet
    Dim arrSheet1 As Variant, arrValid As Variant
    Dim dictValid As Object
    Dim lastRowSheet1 As Long, lastRowValid As Long
    Dim i As Long, j As Long
    Dim deleteRows As Range
    Dim key1 As String, key2 As String, key3 As String, key4 As String
    Dim valO As String, valQ As String
    
    ' 禁用屏幕刷新与事件，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 绑定工作表对象，避免Activate切换
    Set wsSheet1 = ThisWorkbook.Worksheets("Sheet1")
    Set wsValid = ThisWorkbook.Worksheets("Validations")
    Set dictValid = CreateObject("Scripting.Dictionary")
    
    ' 获取两表最后行号
    lastRowSheet1 = wsSheet1.Cells(wsSheet1.Rows.Count, 2).End(xlUp).Row
    lastRowValid = wsValid.Cells(wsValid.Rows.Count, 2).End(xlUp).Row
    
    ' 将整表数据加载到内存数组，大幅提升访问速度
    arrSheet1 = wsSheet1.Range("A2:CL" & lastRowSheet1).Value
    arrValid = wsValid.Range("A2:CL" & lastRowValid).Value
    
    ' 预存Validations表的校验规则到字典，生成复合键用于快速匹配
    For j = 1 To UBound(arrValid, 1)
        ' 处理O/S/W列的空值逻辑
        valO = arrValid(j, 15) ' 列O对应数组第15列
        If valO = "" Then valO = arrValid(j, 19) ' 列S对应数组第19列
        If valO = "" Then valO = arrValid(j, 23) ' 列W对应数组第23列
        
        ' 处理Q/U/Y列的空值逻辑
        valQ = arrValid(j, 17) ' 列Q对应数组第17列
        If valQ = "" Then valQ = arrValid(j, 21) ' 列U对应数组第21列
        If valQ = "" Then valQ = arrValid(j, 25) ' 列Y对应数组第25列
        
        ' 提取核心校验列的值（列B、BY、CD）
        key1 = arrValid(j, 2) ' 列B对应数组第2列
        key2 = arrValid(j, 77) ' 列BY对应数组第77列
        key3 = arrValid(j, 82) ' 列CD对应数组第82列
        key4 = valO & "|" & valQ
        
        ' 生成唯一复合键，存入字典
        Dim compositeKey As String
        compositeKey = key1 & "|" & key2 & "|" & key3 & "|" & key4
        If Not dictValid.Exists(compositeKey) Then
            dictValid.Add compositeKey, True
        End If
    Next j
    
    ' 遍历Sheet1数据，完成校验与待删除行标记
    For i = 1 To UBound(arrSheet1, 1)
        ' 生成当前行的复合键
        valO = arrSheet1(i, 15)
        If valO = "" Then valO = arrSheet1(i, 19)
        If valO = "" Then valO = arrSheet1(i, 23)
        
        valQ = arrSheet1(i, 17)
        If valQ = "" Then valQ = arrSheet1(i, 21)
        If valQ = "" Then valQ = arrSheet1(i, 25)
        
        key1 = arrSheet1(i, 2)
        key2 = arrSheet1(i, 77)
        key3 = arrSheet1(i, 82)
        key4 = valO & "|" & valQ
        
        compositeKey = key1 & "|" & key2 & "|" & key3 & "|" & key4
        
        ' 匹配校验规则
        If dictValid.Exists(compositeKey) Then
            ' 匹配成功，标记Approve（CL列对应数组第90列）
            arrSheet1(i, 90) = "Approve"
        Else
            ' 匹配失败，标记待删除行
            If deleteRows Is Nothing Then
                Set deleteRows = wsSheet1.Rows(i + 1) ' 数组第1行对应Sheet1第2行
            Else
                Set deleteRows = Union(deleteRows, wsSheet1.Rows(i + 1))
            End If
        End If
    Next i
    
    ' 将数组数据写回Sheet1
    wsSheet1.Range("A2:CL" & lastRowSheet1).Value = arrSheet1
    
    ' 批量删除待删除行
    If Not deleteRows Is Nothing Then
        deleteRows.Delete
    End If
    
    ' 删除Validations工作表
    Application.DisplayAlerts = False
    wsValid.Delete
    Application.DisplayAlerts = True
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

优化说明 #

1. 对象引用替代Activate：直接绑定工作表对象，所有单元格操作通过对象引用完成，彻底消除工作表切换的性能损耗
2. 内存数组读写：将整表数据一次性加载到内存数组，在内存中完成所有对比操作，比直接读写单元格效率提升100倍以上
3. 字典快速匹配：将Validations表的校验规则预存为字典复合键，每次匹配仅需O(1)时间，整体时间复杂度从O(n*m)降至O(n)
4. 批量删除：先标记所有待删除行，最后一次性删除，避免逐行删除导致的Excel重排开销
5. 临时禁用Excel功能：关闭屏幕刷新、事件触发和删除提示，进一步压缩运行耗时

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