如何修改VBA代码实现两工作表B、C双列匹配后复制数据到新表

核心修改逻辑 #

你原来的代码是用B列值作为字典的唯一key，要实现B、C双列同时匹配，只需要将字典的key修改为B列值 + 特殊分隔符 + C列值的拼接结果即可，特殊分隔符可以用|这类不会出现在你的业务数据中的字符，避免误匹配。

完整修改后代码 #

Sub CopyDuplicates()
    MsgBox "Process begin now. if you cannot see any result after processing, " & _
           "it means there is no duplicate data between two sheets."
    
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
    Dim ar As Variant, i As Long
    
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set ws3 = Sheets("Sheet3")
    ws3.Cells.Clear

    lr1 = ws1.UsedRange.Rows.Count
    lr2 = ws2.UsedRange.Rows.Count
    ws1.UsedRange.Interior.ColorIndex = xlNone
    ws2.UsedRange.Interior.ColorIndex = xlNone

    ' build dictionary from sheet2 col B + col C
    Dim dict, key As String
    Set dict = CreateObject("Scripting.Dictionary")
    
    For r = 1 To lr2
        ' 改动点：拼接B列和C列作为key，用|分隔避免误匹配
        key = Trim(ws2.Cells(r, "B")) & "|" & Trim(ws2.Cells(r, "C"))
        If Len(key) > 1 Then ' 拼接后长度至少大于1，排除两列都为空的情况
            If dict.exists(key) Then
                dict(key) = dict(key) & ";" & r
            Else
                dict.Add key, r
            End If
        End If
    Next

    Application.ScreenUpdating = False
    r3 = 1 ' sheet3
    ' scan sheet 1 looking for to match with sheet 2
    For r = 1 To lr1
        ' 改动点：同样拼接B列和C列生成查询key
        key = Trim(ws1.Cells(r, "B")) & "|" & Trim(ws1.Cells(r, "C"))
        If dict.exists(key) Then
            ' copy multiple matches
            ar = Split(dict(key), ";")
            For i = LBound(ar) To UBound(ar)
                ws1.Range("A" & r).Resize(1, 6).Copy ws3.Range("A" & r3) ' A:F
                ws2.Range("A" & ar(i)).Resize(1, 17).Copy ws3.Range("G" & r3) ' A:Q
                r3 = r3 + 1
            Next
        End If
    Next
   
    Application.ScreenUpdating = True
    MsgBox "Process finished"
End Sub

改动说明 #

• 构造字典时将key = Trim(ws2.Cells(r, "B"))修改为key = Trim(ws2.Cells(r, "B")) & "|" & Trim(ws2.Cells(r, "C"))，同时取B、C两列内容作为唯一标识
• 遍历Sheet1匹配时，也用相同规则拼接B、C列生成key查询字典
• 调整了空值判断条件，避免两列都为空的无效数据被匹配

如果你测试时发现有特殊场景的匹配问题，可以调整分隔符为其他不会出现在你的业务数据中的字符即可。

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