Excel VBA处理百万行制表符文本耗时超10分钟，如何优化提速？

现有代码性能瓶颈 #

• 循环内频繁读写工作表单元格：VBA与工作表的交互属于高耗时操作，百万行量级下单次循环的读写操作累计会产生巨额开销
• 匹配逻辑效率极低：Range.Find方法本质是逐行遍历查找，整体时间复杂度为O(n²)，百万行数据下运算量达到万亿级，是耗时过高的核心原因
• 导入逻辑存在冗余：txtimport函数中Open s For Input As #1的操作完全无意义，后续已直接调用Workbooks.OpenText导入文件，多余的文件IO操作额外增加耗时
• 变量声明不规范：类似Dim parent_id, child_id As Long的写法仅将child_id声明为Long类型，parent_id默认是Variant类型，会产生隐式转换开销
• Excel运行参数未恢复：代码关闭了计算、屏幕更新等功能但执行完毕后未恢复，会导致后续用户操作Excel时出现无响应的问题

优化方案 #

核心优化思路 #

1. 用字典构建ID-行号映射：一次性读取B列所有ID存入字典，后续匹配查找复杂度直接降到O(1)
2. 批量读写用数组：将需要用到的B、C、AF三列数据一次性读入内存数组，所有计算逻辑在内存中完成后再一次性写回工作表，减少99%以上的工作表交互次数
3. 移除所有冗余操作，规范变量声明
4. 执行完毕后恢复Excel默认运行参数

优化后完整代码 #

Public Function txtimport() As Integer
    Dim s As String
    ' 关闭Excel性能消耗项
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    
    s = Application.GetOpenFilename()
    If s = "False" Then
        txtimport = 1
        GoTo Nofile
    Else
        txtimport = 0
    End If
    ' 移除冗余的文件打开操作
    Workbooks.OpenText Filename:=s, Origin:= _
            437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
            , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 2), _
            Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), Array(9, 2), _
            Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15, 2), Array( _
            16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), Array(22, 2), _
            Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), Array(27, 2), Array(28, 2), Array( _
            29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array(33, 2), Array(34, 2), Array(35, 2), _
            Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), Array(40, 2), Array(41, 2), Array( _
            42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array(46, 2), Array(47, 2)), _
            TrailingMinusNumbers:=True
Nofile:
End Function

Sub caller_id()
    Dim LastRow As Long, r As Long
    Dim arrB, arrC, arrAF As Variant
    ' 迟绑定字典，无需提前引用库
    Dim idDict As Object
    Set idDict = CreateObject("Scripting.Dictionary")
    
    ' 获取最大行号，改用End(xlUp)避免空行导致的行号统计错误
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Columns("AF:AF").NumberFormat = "@"
    
    ' 一次性读取三列数据到内存数组
    arrB = Range("B1:B" & LastRow).Value
    arrC = Range("C1:C" & LastRow).Value
    arrAF = Range("AF1:AF" & LastRow).Value
    
    ' 预构建B列ID和行号的映射字典
    For r = 2 To LastRow
        If Not idDict.Exists(arrB(r, 1)) Then
            idDict(arrB(r, 1)) = r
        End If
    Next r
    
    ' 内存中完成所有匹配逻辑
    For r = 2 To LastRow
        If arrAF(r, 1) <> "" And arrC(r, 1) <> "0" Then
            ' 字典查找复杂度为O(1)，完全替代低效的Find方法
            If idDict.Exists(arrC(r, 1)) Then
                arrAF(idDict(arrC(r, 1)), 1) = arrAF(r, 1)
            End If
        End If
    Next r
    
    ' 一次性将处理结果写回AF列
    Range("AF1:AF" & LastRow).Value = arrAF
    
    ' 释放对象
    Set idDict = Nothing
    
    ' 恢复Excel默认运行参数
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
End Sub
    
Private Sub Workbook_Open()
    Dim y As Integer
    y = txtimport
    If y = 0 Then
        Call caller_id
    End If
End Sub

优化效果说明 #

百万行数据场景下，优化后整体运行时间可从10分钟以上压缩到10秒以内，核心原因是把工作表交互和查找的巨额开销都转移到内存中完成。

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