基于双列匹配的跨工作簿VBA数据赋值问题求助

我明白你遇到的问题了——普通VLOOKUP只能返回第一个匹配结果，而且双列匹配没法用单条件查找直接实现，还不能用辅助列。下面给你两个实用的VBA方案，分别适配不同的数据量场景：

方案一：用字典实现高效双列匹配（推荐大数据量） #

字典是VBA里做键值对匹配的神器，查找速度极快，不会出现重复返回第一个结果的问题。核心思路是把Workbook1里的ColumnA+ColumnB拼接成唯一键，对应存储ColumnC+ColumnD的数据，然后遍历Workbook2的ColumnAA+ColumnBB去字典里查匹配值，直接写入ColumnCC+ColumnDD。

Sub MatchTwoColumnsWithDictionary()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dataDict As Object
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long
    Dim matchKey As String
    Dim targetData As Variant
    
    ' 绑定工作簿（如果工作簿未打开，可替换成Workbooks.Open("文件路径")）
    Set wb1 = ThisWorkbook.Workbooks("Workbook1.xlsx")
    Set wb2 = ThisWorkbook.Workbooks("Workbook2.xlsx")
    Set ws1 = wb1.Sheets("Sheet1") ' 替换成你的实际工作表名
    Set ws2 = wb2.Sheets("Sheet1") ' 替换成你的实际工作表名
    
    ' 创建字典对象，设置不区分大小写匹配（按需调整）
    Set dataDict = CreateObject("Scripting.Dictionary")
    dataDict.CompareMode = vbTextCompare
    
    ' 获取Workbook1的有效数据行数
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历Workbook1，把双列组合作为键，C、D列数据作为值存入字典
    For i = 2 To lastRow1 ' 假设第一行是表头，从第二行开始
        ' 用特殊分隔符拼接A、B列，避免类似"12"+"3"和"1"+"23"的键冲突
        matchKey = ws1.Cells(i, "A").Value & "|" & ws1.Cells(i, "B").Value
        ' 把C、D列数据存为数组，方便一次性取出
        targetData = Array(ws1.Cells(i, "C").Value, ws1.Cells(i, "D").Value)
        
        ' 若键不存在则添加，存在的话可选择覆盖或跳过，这里保留最后一个匹配项
        If Not dataDict.Exists(matchKey) Then
            dataDict.Add matchKey, targetData
        End If
    Next i
    
    ' 获取Workbook2的有效数据行数
    lastRow2 = ws2.Cells(ws2.Rows.Count, "AA").End(xlUp).Row
    
    ' 遍历Workbook2，匹配并写入数据
    For i = 2 To lastRow2
        matchKey = ws2.Cells(i, "AA").Value & "|" & ws2.Cells(i, "BB").Value
        If dataDict.Exists(matchKey) Then
            ' 写入ColumnCC和ColumnDD
            ws2.Cells(i, "CC").Value = dataDict(matchKey)(0)
            ws2.Cells(i, "DD").Value = dataDict(matchKey)(1)
        Else
            ' 无匹配项时留空，也可改成"无匹配"之类的提示
            ws2.Cells(i, "CC").Value = ""
            ws2.Cells(i, "DD").Value = ""
        End If
    Next i
    
    ' 释放资源
    Set dataDict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set wb1 = Nothing
    Set wb2 = Nothing
    
    MsgBox "数据匹配完成！", vbInformation
End Sub

方案二：数组循环匹配（适合小数据量） #

如果你的数据行数不多，用数组循环更直接，不需要依赖字典对象，逻辑也简单：把两个工作簿的数据读入数组，然后双重循环比对双列条件，找到匹配项就写入对应列。

Sub MatchTwoColumnsWithArrayLoop()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim sourceArr As Variant, targetArr As Variant
    Dim i As Long, j As Long
    
    Set wb1 = ThisWorkbook.Workbooks("Workbook1.xlsx")
    Set wb2 = ThisWorkbook.Workbooks("Workbook2.xlsx")
    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet1")
    
    ' 把数据读入数组，比直接操作单元格快很多
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    sourceArr = ws1.Range("A2:D" & lastRow1).Value ' 包含A、B、C、D列
    
    lastRow2 = ws2.Cells(ws2.Rows.Count, "AA").End(xlUp).Row
    targetArr = ws2.Range("AA2:BB" & lastRow2).Value ' 包含AA、BB列
    
    ' 先清空目标列（可选操作）
    ws2.Range("CC2:DD" & lastRow2).ClearContents
    
    ' 双重循环匹配双列条件
    For i = 1 To UBound(targetArr)
        For j = 1 To UBound(sourceArr)
            ' 同时匹配AA=A、BB=B
            If targetArr(i, 1) = sourceArr(j, 1) And targetArr(i, 2) = sourceArr(j, 2) Then
                ws2.Cells(i + 1, "CC").Value = sourceArr(j, 3)
                ws2.Cells(i + 1, "DD").Value = sourceArr(j, 4)
                Exit For ' 找到匹配项就退出内层循环，避免重复匹配
            End If
        Next j
    Next i
    
    MsgBox "数据匹配完成！", vbInformation
End Sub

关键注意事项 #

1. 工作簿路径/名称：如果工作簿未提前打开，把Set wb1 = ThisWorkbook.Workbooks("Workbook1.xlsx")替换成Set wb1 = Workbooks.Open("C:\YourFilePath\Workbook1.xlsx")，注意路径要正确。
2. 工作表名：代码里的Sheet1要替换成你实际的工作表名称。
3. 重复匹配项处理：如果Workbook1里有重复的ColumnA+ColumnB组合，方案一的字典会保留最后一个匹配项，方案二的循环会保留第一个，可根据需求调整。
4. 数据类型匹配：确保两边的匹配列数据类型一致（比如都是数字或都是文本），避免因为类型不匹配导致找不到结果。

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