Compare two worksheet and copy duplicate data to a new worksheet

Question

I am trying to compare two sheets and copy the duplicate data to an new sheet.

Here is what I am trying to do:

New sheet= sheet3

If column B (sheet1) = column B (sheet2)

Then copy sheet1 column A to F to sheet3 column A to F, and also copy sheet2 column A to Q to sheet3 column column G to W.

Basically I want to copy and paste duplicate sheet1 data next to sheet2 data in sheet3. And also the column B (sheet1) can match with more than one column B (sheet2). So the data in sheet1 might need to copy multiple times.

Below is the code I currently have, it can only copy duplicate data from sheet2 to sheet3.


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, lc1 As Long, lc2 As Long, r As Long
Dim rng As Range, cell As Range
Application.ScreenUpdating = False

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")

ws3.Cells.Clear
lr2 = ws2.UsedRange.Rows.Count
lc1 = ws1.UsedRange.Columns.Count
lc2 = ws2.UsedRange.Columns.Count

ws1.UsedRange.Interior.ColorIndex = xlNone
ws2.UsedRange.Interior.ColorIndex = xlNone

Set rng = ws2.Range("B1:B" & lr2)
For Each cell In rng
    If Application.CountIf(ws1.Range("B:B"), cell.Value) > 0 Then
        r = Application.Match(cell.Value, ws1.Range("B:B"), 0)
        cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2)
    End If
Next cell
ws3.Rows(1).Delete
Application.ScreenUpdating = True
MsgBox “Process finished”
End Sub

I am still a beginner of VBA, thank you so much for your help.


This is my expected return：

I assume that sheet1 and sheet2 only have column A B C


A    B    C    D    E    F
1 HO1335 KKK   8 HO1335 LLL
1 HO1335 KKK   9 HO1335 OLK
1 HO1335 KKK   0 HO1335 OKL
2 HO1335 HHH   8 HO1335 LLL
2 HO1335 HHH   9 HO1335 OLK
2 HO1335 HHH   0 HO1335 OKL

Are you doing anyting with r? Do you not need to say ws1.rows(r).copy? — Nathan_Sav

CDP1802 CDP1802 · Accepted Answer · 2021-07-29T10:40:54

Consider using a Dictionary Object as a lookup.

Update - many to many matches

Option Explicit
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
    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
    ' scan sheet 1 looking for to match with sheet 2
    For r = 1 To lr1
        key = Trim(ws1.Cells(r, "B"))
        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

Compare two worksheet and copy duplicate data to a new worksheet

1 Answers