VBA匹配两工作表A列值 输出对应B列值的代码实现与纠错

原代码核心错误说明 #

两段示例代码无法正常运行，核心问题如下：

• 循环匹配版本错误：
  • 把存储单元格值的数组变量sheet1colA/sheet2colA当成工作表名传入Worksheets()方法，直接触发运行时错误
  • 匹配成功后没有退出内层循环，若Sheet2存在重复值会重复执行无意义的赋值逻辑
  • 未匹配项收集逻辑取数错误，错误读取Sheet2的列值，实际应该收集Sheet1中未匹配的待查值
• Match函数版本错误：
  • 直接给Application.Match传入多单元格区域作为查找值时，只会返回区域第一个值的匹配结果，无法逐行完成匹配
  • Sheet2取数的Range地址拼接错误，"A2:A27" & match会生成无效的单元格地址

可直接运行的实现方案 #

提供两种实现方式，第一种逻辑直观适合新手理解，第二种性能更优适合数据量较大的场景。

方案1：双层循环实现 #

逻辑和最初的写法思路一致，修正了所有引用错误，加入了基础性能优化和未匹配项提示：

Sub loopMatch()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim arr1 As Variant, arr2 As Variant
    Dim i As Long, j As Long
    Dim isMatched As Boolean
    Dim unMatchedList As String
    
    ' 绑定工作表对象，避免工作表名引用错误
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 批量将数据读入数组，比逐单元格读取性能高10倍以上
    arr1 = ws1.Range("A3:A25").Value ' Sheet1待匹配值范围
    arr2 = ws2.Range("A2:B27").Value ' Sheet2直接读取A/B两列，匹配后可直接取对应B列值
    
    unMatchedList = "以下条目未找到匹配项：" & vbCrLf
    
    ' 遍历Sheet1每一个待匹配值
    For i = LBound(arr1) To UBound(arr1)
        isMatched = False
        ' 遍历Sheet2查找匹配项
        For j = LBound(arr2) To UBound(arr2)
            ' 统一转成字符串做精确匹配，避免数字/文本格式不一致导致匹配失败
            If CStr(arr2(j, 1)) = CStr(arr1(i, 1)) Then
                ' 匹配成功，将Sheet2 B列值写入Sheet1对应行B列
                ws1.Cells(i + 2, "B").Value = arr2(j, 2)
                isMatched = True
                Exit For ' 找到匹配后立刻退出内层循环，减少无意义遍历
            End If
        Next j
        ' 记录未匹配项
        If Not isMatched Then
            ws1.Cells(i + 2, "B").Value = "未匹配"
            unMatchedList = unMatchedList & arr1(i, 1) & "; "
        End If
    Next i
    
    ' 弹出未匹配项提示，不需要可直接注释删除
    If unMatchedList <> "以下条目未找到匹配项：" & vbCrLf Then
        MsgBox unMatchedList, vbInformation
    End If
End Sub

方案2：字典匹配实现（推荐） #

用字典键值对预存Sheet2的匹配关系，只需遍历两次数组即可完成全部匹配，数据量超过1000行时速度比双层循环快几十倍，采用后期绑定写法，无需手动添加库引用即可直接运行：

Sub dictMatch()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim arr1 As Variant, arr2 As Variant
    Dim i As Long
    Dim matchDict As Object
    Dim unMatchedList As String
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    ' 后期绑定字典对象
    Set matchDict = CreateObject("Scripting.Dictionary")
    matchDict.CompareMode = vbTextCompare ' 匹配时不区分英文大小写，需要区分请删除此行
    
    ' 先将Sheet2的匹配关系存入字典：key为A列值，item为对应B列值
    arr2 = ws2.Range("A2:B27").Value
    For i = LBound(arr2) To UBound(arr2)
        ' 避免Sheet2A列重复值触发字典报错
        If Not matchDict.Exists(CStr(arr2(i, 1))) Then
            matchDict.Add CStr(arr2(i, 1)), arr2(i, 2)
        End If
    Next i
    
    ' 批量读取Sheet1A/B列数据，结果直接写入数组，最后一次性回写工作表
    arr1 = ws1.Range("A3:B25").Value
    unMatchedList = "以下条目未找到匹配项：" & vbCrLf
    For i = LBound(arr1) To UBound(arr1)
        If matchDict.Exists(CStr(arr1(i, 1))) Then
            arr1(i, 2) = matchDict(CStr(arr1(i, 1)))
        Else
            arr1(i, 2) = "未匹配"
            unMatchedList = unMatchedList & arr1(i, 1) & "; "
        End If
    Next i
    ' 结果批量回写到工作表
    ws1.Range("A3:B25").Value = arr1
    
    ' 弹出未匹配项提示，不需要可直接注释删除
    If unMatchedList <> "以下条目未找到匹配项：" & vbCrLf Then
        MsgBox unMatchedList, vbInformation
    End If
End Sub

使用说明 #

• 如果数据范围有调整，直接修改代码中Range()对应的单元格地址即可
• 循环版中ws1.Cells(i + 2, "B")的+2为行偏移量，计算规则为「待匹配区域起始行号-1」，比如待匹配值从A1开始，偏移量改为+0即可；字典版无需手动计算偏移，修改Range地址即可自动适配
• 所有匹配默认是精确匹配，统一转成字符串比较，避免数字/文本格式不一致导致匹配失败
• 不需要未匹配项弹窗提示，直接注释掉MsgBox相关代码段即可

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