比较两个工作表并将重复数据复制到新的工作表（使用两列进行比较）。

Question

我正在尝试比较两个表格的两列，然后将重复数据复制到一个新的表格中。

以下是我目前拥有的代码：

Sub CopyDuplicates()
    MsgBox "处理开始。如果在处理后没有看到任何结果，则意味着两个表格之间没有重复数据。"

    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

    ' 从 sheet2 的 col B 构建字典
    Dim dict, key As String
    Set dict = CreateObject("Scripting.Dictionary")

    For r = 1 To lr2
        key = Trim(ws2.Cells(r, "B"))
        If Len(key) > 0 Then
            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
    ' 扫描 sheet1，查找与 sheet2 匹配的数据
    For r = 1 To lr1
        key = Trim(ws1.Cells(r, "B"))
        If dict.exists(key) Then
            ' 复制多个匹配项
            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 "处理完成"
End Sub

它只能比较两个表格的一列，即列 B。但是我想同时比较列 B 和 C，当两个表格的列 B 和 C 匹配时，将整行数据复制到新表格（Sheet3）中。

这是我期望的返回：

我假设 sheet1 和 sheet2 只有列 A、B、C

A     B     C     D     E    F
GRF HO1335 KKK   BLG HO1335 KKK
GRF HO1335 KKK   SKT HO1335 KKK
GRF HO1335 KKK   T1  HO1335 KKK
DWG HO1335 HHH   CLG HO1335 HHH
DWG HO1335 HHH   FNC HO1335 HHH
DWG HO1335 HHH   BYG HO1335 HHH

我可以比较两列同时吗？ 我是 VBA 的初学者，所以不太熟悉这方面的知识。非常感谢您的帮助。