如何优化含SUMPRODUCT计算的VBA代码以缩短执行耗时

问题描述 #

对超过1万条记录执行如下0/1标记生成VBA代码时，程序运行时长可达15至25分钟，生成的标记值后续用于数据筛选、趋势图生成，需优化代码降低执行耗时。
原代码如下：

Sub Flags()

    Dim wSht As Worksheet
    Set wSht = ActiveSheet

    'New_Columns_Calculation

    With wSht.Range("HI2:HI" & wSht.Cells(Rows.Count, "HH").End(xlUp).Row)
        .Formula = "=IF(SUMPRODUCT(($HF$2:HF2=HF2) * ($HG$2:HG2=HG2))>1,0,1)"
        .Value = .Value '将公式转换为值
    End With
    
End Sub

性能瓶颈原因 #

原代码运行缓慢的核心原因有两点：

• 写入的SUMPRODUCT公式为逐行相对引用，每一行计算都会从第2行遍历到当前行做重复匹配计算，总计算复杂度为O(n²)，1万行数据会产生近亿次单元格读取与计算操作。
• 未关闭Excel屏幕刷新、自动重算、事件触发等默认交互逻辑，大量单元格读写操作会触发频繁的界面重绘，额外消耗大量性能。

优化方案 #

核心优化思路是将O(n²)的重复遍历计算改为O(n)的字典去重逻辑，所有计算放在内存中完成，减少单元格读写次数，同时临时关闭不必要的Excel交互开销：

• 代码运行前临时关闭屏幕更新、自动计算、事件触发，运行结束后自动恢复，避免额外的界面与计算开销。
• 将需要判断的HF、HG列数据一次性读入内存数组，避免逐单元格读取的COM交互开销。
• 借助字典对象的键唯一性做重复值判断：遍历行数据时，将HF列与HG列的值拼接作为唯一键，若键已存在则标记为0，若不存在则标记为1并将键存入字典，全程仅需遍历一次数据。
• 所有计算完成后，将结果数组一次性写入HI列，避免逐单元格写入的开销。

优化后完整代码：

Sub Flags_Optimized()
    Dim wSht As Worksheet
    Dim lastRow As Long, i As Long
    Dim dataArr As Variant, resArr As Variant
    Dim dict As Object, key As String
    
    ' 临时关闭Excel非必要交互，降低性能开销
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 异常兜底，确保出错时也能恢复Excel默认设置
    On Error GoTo Cleanup
    Set wSht = ActiveSheet
    lastRow = wSht.Cells(wSht.Rows.Count, "HH").End(xlUp).Row
    
    ' 一次性读取HF、HG列待判断数据到内存
    dataArr = wSht.Range("HF2:HG" & lastRow).Value
    ReDim resArr(1 To UBound(dataArr, 1), 1 To 1)
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 单次遍历完成标记判断
    For i = 1 To UBound(dataArr, 1)
        ' 拼接两列值作为唯一键，加入分隔符避免不同值拼接后产生重复键
        key = dataArr(i, 1) & "|SEP|" & dataArr(i, 2)
        If dict.Exists(key) Then
            resArr(i, 1) = 0
        Else
            resArr(i, 1) = 1
            dict.Add key, 1
        End If
    Next i
    
    ' 一次性将结果写入HI列
    wSht.Range("HI2:HI" & lastRow).Value = resArr

Cleanup:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "运行出错：" & Err.Description, vbExclamation
End Sub

优化后1万条数据处理耗时通常在1秒以内，10万级数据量也可在数秒内完成，计算结果与原公式逻辑完全一致。

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