Excel VBA实现双工作簿两列数据匹配并复制对应偏移单元格方案咨询

实现思路 #

• 无需新增辅助列合并单元格内容，使用字典对象存储双列组合的匹配键与对应行的映射关系
• 双列拼接时加入特殊分隔符避免不同内容拼接出现重复匹配
• 两次遍历完成全量操作，比嵌套循环效率更高，适配万行级数据场景

可直接运行的代码 #

Sub 双列匹配复制数据()
    ' 声明变量
    Dim w1 As Worksheet, w2 As Worksheet
    Dim dict As Object
    Dim key As String
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long
    
    ' 字典晚绑定，无需提前引用库
    Set dict = CreateObject("Scripting.Dictionary")
    ' 定义两个工作表对象，可根据实际文件名、表名修改
    Set w1 = Workbooks("Job Number with Labor Code.xlsx").Worksheets("LaborData")
    Set w2 = Workbooks("Labor Report Project Hours.xlsx").Worksheets("Sheet1")
    
    ' 获取两个表的最后一行行号
    lastRow1 = w1.Cells(w1.Rows.Count, "C").End(xlUp).Row
    lastRow2 = w2.Cells(w2.Rows.Count, "A").End(xlUp).Row
    
    ' 第一步：遍历wb2的匹配列，生成匹配字典
    ' wb2匹配列是A、B列，从第8行开始，可根据实际起始行修改
    For i = 8 To lastRow2
        ' 用|作为分隔符拼接双列内容作为键，避免匹配混淆
        key = w2.Cells(i, "A").Value & "|" & w2.Cells(i, "B").Value
        ' 键存对应行号，也可直接存要复制的内容按需调整
        If Not dict.exists(key) Then
            dict(key) = i
        End If
    Next i
    
    ' 第二步：遍历wb1的匹配列，完成匹配复制
    ' wb1匹配列是C、D列，从第4行开始，可根据实际起始行修改
    For i = 4 To lastRow1
        key = w1.Cells(i, "C").Value & "|" & w1.Cells(i, "D").Value
        ' 匹配成功则复制对应内容
        If dict.exists(key) Then
            ' 示例：将wb2匹配行的C列值 复制到 wb1当前行的E列，可根据实际偏移需求修改列号
            w1.Cells(i, "E").Value = w2.Cells(dict(key), "C").Value
            ' 如果需要复制格式，取消下面注释即可
            ' w2.Cells(dict(key), "C").Copy
            ' w1.Cells(i, "E").PasteSpecial Paste:=xlPasteFormats
            ' 如果需要复制整行多列，用Resize即可，比如复制wb2匹配行C到D列共2列到wb1的E列开始
            ' w1.Cells(i, "E").Resize(1, 2).Value = w2.Cells(dict(key), "C").Resize(1, 2).Value
        End If
    Next i
    
    ' 释放对象
    Set dict = Nothing
    Set w1 = Nothing
    Set w2 = Nothing
    MsgBox "匹配操作完成"
End Sub

自定义修改说明 #

• 可根据实际业务调整匹配列的列号、起始行号
• 可修改复制的目标列、源列，单值/多列复制可通过Resize方法实现
• 如需复制格式、公式，可调整粘贴参数即可

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