(Solved) – Compare two worksheets and built new with duplicates from both


I am trying to build a code that will compare two worksheets and collect duplicates to another worksheet. Target is to:

  1. Detect duplicate
  2. Copy duplicate row from worksheet Germany to Sheet1
  3. Copy duplicate row from worksheet Austria below previous to Sheet1
  4. continue until all duplicates are listed from both worksheets Germany and Austria to Sheet1

I have this code, but the problem is that it collects only duplicates. So if I have 24 duplicates in total, on Sheet1 I would like to see all of them from both worksheets Germany and Austria to be able to compare all the other information.

My data is in columns A:K. I am comparing data by column B.

My current code:

Sub CopyDuplicates()
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("Germany")
Set ws2 = Sheets("Austria")
Set ws3 = Sheets("Sheet1")

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("B2: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)
        'ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, lc1)).Interior.Color = vbRed
        'ws2.Range(ws2.Cells(r, 1), ws2.Cells(r, lc2)).Interior.Color = vbRed
        cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2)
    End If
Next cell
Application.ScreenUpdating = True
End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *