将IFERROR+VLOOKUP公式转换为VBA字典数组实现求助

核心优化思路 #

• 一次性将外部工作簿的三个工作表数据读入内存数组，再转存为字典结构，彻底避免公式反复读写工作表的低效IO操作
• 将当前待匹配数据批量读入数组，完成字典匹配后一次性写回工作表，把百万级别的零散操作压缩为几次批量操作

VBA代码实现 #

Sub FastMatchWithDict()
    Dim wsTarget As Worksheet
    Dim wbData As Workbook
    Dim arrSheet1, arrSheet2, arrSheet3, arrTarget, arrResult
    Dim dictID As Object, dictTA As Object, dictISRC As Object
    Dim i As Long, lastRow As Long
    
    ' 关闭屏幕刷新和事件，最大化运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 初始化三个匹配字典
    Set dictID = CreateObject("Scripting.Dictionary")
    Set dictTA = CreateObject("Scripting.Dictionary")
    Set dictISRC = CreateObject("Scripting.Dictionary")
    ' 不区分大小写匹配，需区分则删除以下三行
    dictID.CompareMode = vbTextCompare
    dictTA.CompareMode = vbTextCompare
    dictISRC.CompareMode = vbTextCompare
    
    ' 打开外部数据工作簿（替换为你的实际文件路径）
    Set wbData = Workbooks.Open("C:\YourFileLocation\data.xlsx")
    
    ' 读取Sheet1数据，构建ID对应第7列值的字典
    arrSheet1 = wbData.Sheets("Sheet1").Range("A:G").Value
    For i = LBound(arrSheet1) To UBound(arrSheet1)
        If Not dictID.Exists(arrSheet1(i, 1)) Then
            dictID(arrSheet1(i, 1)) = arrSheet1(i, 7)
        End If
    Next i
    
    ' 读取Sheet2数据，构建TA对应G列值的字典（原公式E:G的第3列即G列）
    arrSheet2 = wbData.Sheets("Sheet2").Range("E:G").Value
    For i = LBound(arrSheet2) To UBound(arrSheet2)
        If Not dictTA.Exists(arrSheet2(i, 1)) Then
            dictTA(arrSheet2(i, 1)) = arrSheet2(i, 3)
        End If
    Next i
    
    ' 读取Sheet3数据，构建ISRC对应G列值的字典（原公式F:G的第2列即G列）
    arrSheet3 = wbData.Sheets("Sheet3").Range("F:G").Value
    For i = LBound(arrSheet3) To UBound(arrSheet3)
        If Not dictISRC.Exists(arrSheet3(i, 1)) Then
            dictISRC(arrSheet3(i, 1)) = arrSheet3(i, 2)
        End If
    Next i
    
    ' 关闭外部工作簿，无需保存
    wbData.Close SaveChanges:=False
    
    ' 指定待匹配的目标工作表（替换为你的工作表名称）
    Set wsTarget = ThisWorkbook.Sheets("YourTargetSheet")
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    ' 读取待匹配的ID/TA/ISRC数据到数组
    arrTarget = wsTarget.Range("A2:C" & lastRow).Value
    ReDim arrResult(1 To UBound(arrTarget), 1 To 1)
    
    ' 批量执行匹配逻辑
    For i = LBound(arrTarget) To UBound(arrTarget)
        ' 优先匹配ID
        If dictID.Exists(arrTarget(i, 1)) Then
            arrResult(i, 1) = dictID(arrTarget(i, 1))
        ' 其次匹配TA
        ElseIf dictTA.Exists(arrTarget(i, 2)) Then
            arrResult(i, 1) = dictTA(arrTarget(i, 2))
        ' 最后匹配ISRC
        ElseIf dictISRC.Exists(arrTarget(i, 3)) Then
            arrResult(i, 1) = dictISRC(arrTarget(i, 3))
        ' 无匹配值则留空
        Else
            arrResult(i, 1) = ""
        End If
    Next i
    
    ' 将匹配结果一次性写入Result列（D列）
    wsTarget.Range("D2:D" & lastRow).Value = arrResult
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "匹配完成！", vbInformation
End Sub

使用注意事项 #

• 替换代码中的"C:\YourFileLocation\data.xlsx"为实际的外部数据文件路径
• 替换"YourTargetSheet"为存放待匹配数据的工作表名称
• 若需要区分大小写匹配，删除代码中三行CompareMode设置语句
• 运行前建议备份数据，避免意外错误

内容的提问来源于stack exchange，提问作者Hoang Nguyen Dinh