如何通过VBA加速Index Match函数，优化耗时20秒的VBA代码

你当前的代码耗时主要来自循环中反复调用工作表函数+逐单元格读写——这两种操作在VBA里都是性能瓶颈，尤其是当数据量较大时。用数组+字典替代原逻辑，能把运行时间从几十秒压缩到几百毫秒，下面是具体的优化思路和代码：

原代码的核心性能问题 #

• 每次循环都调用WorksheetFunction.Match和Index，相当于反复让VBA和Excel工作表引擎交互，开销极大
• 逐行读写Cells(k,2)、Cells(k,3)，单元格IO是VBA里最慢的操作之一
• 不必要的Activate和Select操作，虽然不影响功能，但会额外消耗资源

优化后的代码 #

Sub feuille_distinct()
    Dim k As Long
    Dim timer0 As Double
    Dim wsDedoubl As Worksheet
    Dim arrClaimNumbers As Variant, arrCourrier As Variant, arrAct As Variant
    Dim arrTarget As Variant
    Dim claimDict As Object
    
    ' 初始化环境
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    timer0 = Timer()
    
    ' 避免Activate，直接引用工作表
    Set wsDedoubl = ThisWorkbook.Sheets("DEDOUBL")
    Set claimDict = CreateObject("Scripting.Dictionary")
    
    ' 1. 将需要查找的数据源读入数组（内存操作，速度极快）
    With ThisWorkbook.Names("ALLSIN_claimnumber").RefersToRange
        arrClaimNumbers = .Value
        arrCourrier = .Offset(0, ThisWorkbook.Names("ALLSIN_courrier").RefersToRange.Column - .Column).Value
        arrAct = .Offset(0, ThisWorkbook.Names("ALLSIN_act").RefersToRange.Column - .Column).Value
    End With
    
    ' 2. 用字典建立ClaimNumber到行号的映射（O(1)查找速度）
    For k = LBound(arrClaimNumbers, 1) To UBound(arrClaimNumbers, 1)
        If Not claimDict.Exists(arrClaimNumbers(k, 1)) Then
            claimDict(arrClaimNumbers(k, 1)) = k
        End If
    Next k
    
    ' 3. 将目标列读入数组，批量处理
    With wsDedoubl
        Dim lastRow As Long
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        arrTarget = .Range("A2:C" & lastRow).Value ' 读取A-C列数据，A列是要匹配的ClaimNumber
        
        For k = LBound(arrTarget, 1) To UBound(arrTarget, 1)
            If claimDict.Exists(arrTarget(k, 1)) Then
                Dim matchRow As Long
                matchRow = claimDict(arrTarget(k, 1))
                arrTarget(k, 2) = arrCourrier(matchRow, 1)
                arrTarget(k, 3) = arrAct(matchRow, 1)
            Else
                ' 处理找不到匹配的情况，可根据需求修改
                arrTarget(k, 2) = "无匹配"
                arrTarget(k, 3) = "无匹配"
            End If
        Next k
        
        ' 4. 一次性将处理后的数组写入工作表（仅一次IO操作）
        .Range("A2:C" & lastRow).Value = arrTarget
    End With
    
    ' 输出耗时
    Debug.Print "运行耗时: " & Timer - timer0 & " 秒"
    
    ' 恢复环境
    ThisWorkbook.Sheets("SIMULATEUR").Range("A1").Select ' 保留原需求的选中操作，可根据情况移除
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 释放对象
    Set claimDict = Nothing
    Set wsDedoubl = Nothing
End Sub

优化点说明 #

1. 数组替代单元格读写：把所有需要处理的数据一次性读入内存数组，处理完成后再批量写入，彻底避免逐单元格IO的开销
2. 字典替代Match函数：字典的键值对查找是常数时间复杂度，比Match的线性查找快得多，尤其当数据量很大时优势明显
3. 移除不必要的激活操作：直接通过工作表对象引用单元格，避免Activate带来的额外资源消耗
4. 使用Long类型替代Integer：Excel的行数远超Integer的最大值（32767），用Long避免溢出风险，同时性能更稳定

额外建议 #

• 如果你的ALLSIN_xxx是定义好的名称，确保它们的引用范围正确，避免包含空行
• 如果不需要最终选中SIMULATEUR的A1单元格，可以把那行代码去掉，进一步减少操作

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