如何优化VBA区域子字符串查找函数 提升大数据量运行效率

你当前两种方案卡顿的核心原因都是重复产生了大量不必要的工作表单元格读取开销：

• 原数组公式每计算1行数据，就要遍历读取参考表250个单元格做匹配，3万行数据累计产生750万次单元格IO操作，原生单元格对象的读取开销极高，是卡顿的核心来源
• 原VBA自定义函数存在三个明显的性能缺陷：
  • 每调用一次函数（也就是每处理1行数据），就在循环内重复读取RefSht.Range("A1:A250")区域加载数组，产生大量重复IO
  • 已经通过数组遍历拿到匹配关键词后，还调用Range.Find二次查询工作表获取行号，属于完全冗余的操作
  • 没有做参考表的内存缓存，每次函数调用都重复走一遍读表、遍历的全流程，资源浪费严重

核心优化逻辑是首次调用函数时一次性把全部参考规则加载到内存字典中缓存，后续所有匹配操作全部在内存中完成，不再重复读取工作表单元格，3万行数据的处理时间可以压缩到1秒以内，完全不会卡顿。

Function BankRef(BankDescrip As String) As String
    ' 静态变量常驻内存，工作簿打开后仅首次调用时初始化一次
    Static refMap As Object
    Dim i As Long
    Dim refData As Variant
    Dim matchKeys As Variant
    
    ' 初始化参考表缓存，仅执行1次
    If refMap Is Nothing Then
        Set refMap = CreateObject("Scripting.Dictionary")
        ' 一次性读取全部参考规则到数组，仅产生1次区域读取操作
        refData = ThisWorkbook.Sheets("ref").Range("A1:B250").Value
        For i = 1 To UBound(refData, 1)
            If Not IsError(refData(i, 1)) And Trim(refData(i, 1)) <> "" Then
                refMap(Trim(refData(i, 1))) = Trim(refData(i, 2))
            End If
        Next i
    End If
    
    ' 内存遍历匹配，无单元格IO开销
    BankRef = "Not Found"
    matchKeys = refMap.Keys
    For i = 0 To refMap.Count - 1
        ' 默认不区分大小写匹配，需要区分的话把最后一个参数改成vbBinaryCompare
        If InStr(1, BankDescrip, matchKeys(i), vbTextCompare) > 0 Then
            BankRef = refMap(matchKeys(i))
            Exit For
        End If
    Next i
End Function

• 直接替换原有自定义函数即可，不需要修改单元格公式写法
• 如果后续更新了ref工作表的匹配规则，按Ctrl+Alt+F9触发全表强制重算，就会自动重新加载最新的参考规则
• 匹配逻辑默认不区分大小写，如果需要严格区分大小写，把InStr函数的最后一个参数从vbTextCompare改为vbBinaryCompare即可
• 所有Excel批量数据处理场景，优先把需要反复读取的固定数据一次性加载到数组、字典这类内存结构中，避免循环内反复读取单元格对象，是VBA性能优化的核心原则，通常可以带来百倍以上的性能提升

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