VBA处理30万行数据时Range遍历与数组操作的效率优化咨询

数组版本运行更慢的核心原因 #

• 冗余全表读写：代码加载了工作表全部列的数据到数组，处理后又清空全表回写所有列。如果你的表格列数较多，这部分不必要的IO开销远大于数组循环带来的效率提升。
• 未关闭Excel交互功能：默认开启的屏幕更新、自动重算、事件触发机制会在数据写入时重复运行，大幅拖慢执行速度。
• 多条件匹配效率低：多层OR判断需要对每行A列值做最多13次字符串比对，匹配逻辑开销大。

优化后代码（30万行预计运行时间<1秒） #

Sub 优化分类()
    Dim ws As Worksheet
    Dim arrA As Variant, arrAF As Variant, arrAG As Variant
    Dim dict As Object
    Dim i As Long, lastRow As Long
    Dim matchRes As Variant
    
    ' 关闭Excel交互设置，提速核心
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set ws = Worksheets("Input")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' 仅读取需要的3列数据，避免全表加载
    arrA = ws.Range("A1:A" & lastRow).Value
    arrAF = ws.Range("AF1:AF" & lastRow).Value
    arrAG = ws.Range("AG1:AG" & lastRow).Value
    
    ' 提前初始化匹配字典，单次查找即可得到结果
    Set dict = CreateObject("Scripting.Dictionary")
    ' 规则：key为A列编码，value为数组(AG列值, 是否设置AF为QP)
    dict("N149933") = Array("Foundation and Endowment (Charities)", True)
    dict("N103291") = Array("Foundation and Endowment (Charities)", True)
    dict("NS11375") = Array("Foundation and Endowment (Charities)", True)
    dict("N187037") = Array("Foundation and Endowment (Charities)", True)
    dict("N132921") = Array("Foundation and Endowment (Charities)", True)
    dict("NS03359") = Array("Foundation and Endowment (Charities)", True)
    dict("N102301") = Array("Foundation and Endowment (Charities)", True)
    dict("NS35481") = Array("Corporate", False)
    dict("NS07301") = Array("Public Fund (Government)", True)
    dict("NS29802") = Array("Insurance", False)
    dict("NS29803") = Array("Insurance", False)
    dict("NS29801") = Array("Insurance", False)
    
    ' 循环处理行，跳过表头
    For i = 2 To lastRow
        If dict.exists(arrA(i, 1)) Then
            matchRes = dict(arrA(i, 1))
            arrAG(i, 1) = matchRes(0)
            If matchRes(1) Then arrAF(i, 1) = "QP"
        Else
            arrAG(i, 1) = "High Net Worth Individuals"
        End If
    Next i
    
    ' 仅回写修改后的两列，不影响其他列数据
    ws.Range("AF1:AF" & lastRow).Value = arrAF
    ws.Range("AG1:AG" & lastRow).Value = arrAG
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    Set dict = Nothing
    Set ws = Nothing
End Sub

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