如何基于多条件在两工作表间匹配提取数据？VBA优化求助

你的原VBA代码因为逐单元格循环嵌套，在大数据集下效率极低，而且对Sheet1中无对应Sheet2编号的情况处理缺失，导致崩溃或出错。下面是优化后的方案，用**字典（Dictionary）**实现快速查找，完美解决这两个问题。

优化思路 #

1. 批量读取Sheet2数据到数组，避免逐单元格读取的性能损耗
2. 用字典存储运费信息，键采用「产品编号+区域映射+运输方式」的组合（比如1_AP_Air），值为对应的运费成本，实现O(1)时间复杂度的查找
3. 遍历Sheet1的产品编号，根据区域和运输方式从字典中查找对应值，无匹配则留空

完整优化代码 #

Sub FillFreightCosts()
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dict As Object
    Dim arrSheet2 As Variant
    Dim i As Long, j As Long
    Dim pn As String, geoCode As String, freightType As String
    Dim dictKey As String
    Dim regionMap As Object
    
    ' 初始化工作簿和工作表对象
    Set wb = ThisWorkbook ' 或者指定你的工作簿：Workbooks("List2.xlsm")
    Set ws1 = wb.Worksheets("Sheet1")
    Set ws2 = wb.Worksheets("Sheet2")
    
    ' 创建区域映射字典（IN→AP, DE→EMEA, US→NA）
    Set regionMap = CreateObject("Scripting.Dictionary")
    regionMap("IN") = "AP"
    regionMap("DE") = "EMEA"
    regionMap("US") = "NA"
    
    ' 创建存储运费的字典
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 批量读取Sheet2数据到数组（大幅提升性能）
    arrSheet2 = ws2.Range("A1:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 遍历Sheet2数组，填充字典
    For i = 2 To UBound(arrSheet2) ' 从第2行开始跳过表头
        pn = CStr(arrSheet2(i, 1)) ' 产品编号
        geoCode = arrSheet2(i, 6) ' GEO_CODE列（对应原代码的F列）
        freightType = UCase(arrSheet2(i, 9)) ' FREIGHT_TYPE列（对应原代码的I列）
        freightCost = arrSheet2(i, 13) ' FREIGHT_COST列（对应原代码的M列）
        
        ' 只处理有效区域和运输方式
        If regionMap.Exists(geoCode) And (freightType = "AIR" Or freightType = "OCEAN") Then
            ' 构建字典键：产品编号+区域+运输方式
            dictKey = pn & "_" & regionMap(geoCode) & "_" & freightType
            dict(dictKey) = freightCost
        End If
    Next i
    
    ' 遍历Sheet1，填充对应运费
    Dim lastRowSheet1 As Long
    lastRowSheet1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    
    For j = 2 To lastRowSheet1 ' 从第2行开始跳过表头
        pn = CStr(ws1.Cells(j, "A").Value)
        
        ' 填充Air运输方式的各区域
        ws1.Cells(j, "O").Value = IIf(dict.Exists(pn & "_AP_AIR"), dict(pn & "_AP_AIR"), "") ' AP Air（原O列）
        ws1.Cells(j, "P").Value = IIf(dict.Exists(pn & "_EMEA_AIR"), dict(pn & "_EMEA_AIR"), "") ' EMEA Air（原P列）
        ws1.Cells(j, "Q").Value = IIf(dict.Exists(pn & "_NA_AIR"), dict(pn & "_NA_AIR"), "") ' NA Air（原Q列）
        
        ' 填充Ocean运输方式的各区域
        ws1.Cells(j, "R").Value = IIf(dict.Exists(pn & "_AP_OCEAN"), dict(pn & "_AP_OCEAN"), "") ' AP Ocean（原R列）
        ws1.Cells(j, "S").Value = IIf(dict.Exists(pn & "_EMEA_OCEAN"), dict(pn & "_EMEA_OCEAN"), "") ' EMEA Ocean（原S列）
        ws1.Cells(j, "T").Value = IIf(dict.Exists(pn & "_NA_OCEAN"), dict(pn & "_NA_OCEAN"), "") ' NA Ocean（原T列）
    Next j
    
    ' 释放对象
    Set dict = Nothing
    Set regionMap = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set wb = Nothing
    
    MsgBox "数据填充完成！"
End Sub

关键说明 #

1. 区域映射字典：把Sheet2的IN/DE/US映射到Sheet1的AP/EMEA/NA，方便后续统一处理
2. 批量数组读取：一次性读取Sheet2所有数据到数组，比逐单元格读取快几十倍，彻底解决大数据崩溃问题
3. 字典查找：通过组合键快速定位对应运费，避免了原代码嵌套循环的低效比对
4. 缺失值处理：用IIf(dict.Exists(...), ..., "")判断是否有匹配项，无数据则留空，完美处理像编号4这类无对应数据的情况

使用注意事项 #

• 如果你的Excel版本没有启用Scripting.Dictionary，代码会自动通过CreateObject创建，无需额外引用
• 请确认Sheet1的列位置和原代码一致：AP Air在O列、EMEA Air在P列、NA Air在Q列；AP Ocean在R列、EMEA Ocean在S列、NA Ocean在T列，如果列位置有变动，修改代码中对应的列标识即可

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