如何对比两个Workbook指定列，匹配后迁移三列数据至目标Workbook

原代码仅支持源工作簿与目标工作簿的单列对比，并迁移两列数据。现修改为基于两列匹配，匹配成功时将源工作簿的三列数据写入目标工作簿指定列。

修改后的完整代码 #

Sub LookupDataByTwoColumns()

' 定义常量：适配两列匹配、三列数据迁移需求
Const SRC_FILE_NAME As String = "Source.xlsx"
Const SRC_WORKSHEET_ID As Variant = 1
Const SRC_LOOKUP_COLUMNS As String = "A,B" ' 源工作簿用于匹配的两列
Const SRC_VALUE_COLUMNS As String = "C,D,E" ' 源工作簿要迁移的三列

Const DST_FILE_NAME As String = "Destination.xlsx"
Const DST_WORKSHEET_ID As Variant = 1
Const DST_LOOKUP_COLUMNS As String = "D,E" ' 目标工作簿用于匹配的两列
Const DST_VALUE_COLUMNS As String = "H,I,J" ' 目标工作簿接收数据的三列

Dim FolderPath As String: FolderPath = Application.DefaultFilePath & "\"

' 引用源工作簿及数据区域
Dim swb As Workbook: Set swb = Workbooks.Open(FolderPath & SRC_FILE_NAME)
Dim sws As Worksheet: Set sws = swb.Sheets(SRC_WORKSHEET_ID)

Dim srg As Range, srCount As Long
With sws.Range("A1").CurrentRegion
    srCount = .Rows.Count - 1 ' 排除表头行
    Set srg = .Resize(srCount).Offset(1)
End With

' 读取源工作簿两列匹配数据，生成复合键存入字典
Dim slCols() As String: slCols = Split(SRC_LOOKUP_COLUMNS, ",")
Dim slData1() As Variant: slData1 = srg.Columns(slCols(0)).Value
Dim slData2() As Variant: slData2 = srg.Columns(slCols(1)).Value

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare

Dim sr As Long, sCompositeKey As String
For sr = 1 To srCount
    ' 用分隔符拼接两列值，生成唯一复合匹配键
    sCompositeKey = CStr(slData1(sr, 1)) & "|" & CStr(slData2(sr, 1))
    If Not dict.Exists(sCompositeKey) Then
        dict(sCompositeKey) = sr ' 存储对应数据行号
    End If
Next sr

Erase slData1: Erase slData2

' 读取源工作簿要迁移的三列数据到数组
Dim sValCols() As String: sValCols = Split(SRC_VALUE_COLUMNS, ",")
Dim nUpper As Long: nUpper = UBound(sValCols)

Dim sJag() As Variant: ReDim sJag(0 To nUpper)
Dim n As Long
For n = 0 To nUpper
    sJag(n) = srg.Columns(sValCols(n)).Value
Next n

' 引用目标工作簿及数据区域
Dim dwb As Workbook: Set dwb = Workbooks.Open(FolderPath & DST_FILE_NAME)
Dim dws As Worksheet: Set dws = dwb.Sheets(DST_WORKSHEET_ID)

Dim drg As Range, drCount As Long
With dws.Range("A1").CurrentRegion
    drCount = .Rows.Count - 1 ' 排除表头行
    Set drg = .Resize(drCount).Offset(1)
End With

' 读取目标工作簿两列匹配数据
Dim dlCols() As String: dlCols = Split(DST_LOOKUP_COLUMNS, ",")
Dim dlData1() As Variant: dlData1 = drg.Columns(dlCols(0)).Value
Dim dlData2() As Variant: dlData2 = drg.Columns(dlCols(1)).Value

' 初始化目标数据存储数组
Dim dValCols() As String: dValCols = Split(DST_VALUE_COLUMNS, ",")
Dim dJag() As Variant: ReDim dJag(0 To nUpper)

Dim dHelp() As Variant: ReDim dHelp(1 To drCount, 1 To 1)
For n = 0 To nUpper
    dJag(n) = dHelp
Next n
Erase dHelp

' 对比复合键，匹配时写入对应数据
Dim dr As Long, dCompositeKey As String
For dr = 1 To drCount
    dCompositeKey = CStr(dlData1(dr, 1)) & "|" & CStr(dlData2(dr, 1))
    If dict.Exists(dCompositeKey) Then
        For n = 0 To nUpper
            dJag(n)(dr, 1) = sJag(n)(dict(dCompositeKey), 1)
        Next n
    End If
Next dr

' 将迁移数据写入目标工作簿指定列
For n = 0 To nUpper
    drg.Columns(dValCols(n)).Value = dJag(n)
Next n

' 保存并关闭工作簿
dwb.Close SaveChanges:=True
swb.Close SaveChanges:=True

MsgBox "数据匹配迁移完成。", vbInformation

End Sub

关键改动说明 #

• 常量适配：将原单列匹配的常量改为双列配置，同时扩展值列数量为三列，直接对应新需求。
• 复合匹配键：把源/目标工作簿的两列值用|拼接成唯一键，确保只有两列同时匹配时才触发数据迁移。
• 数组逻辑调整：修改匹配数据的读取逻辑，从单列数组改为双列数组，同时扩展值列数组的长度以支持三列数据的存储与写入。

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