Сравните две таблицы и создайте новую с дубликатами от обеих

Question

Я пытаюсь создать код, который будет сравнивать две таблицы и собирать дубликаты на другую таблицу. Цель:

1. Обнаружить дубликат
2. Скопировать дублирующую строку из листа Германия на лист1
3. Скопировать дублирующую строку из листа Австрия ниже предыдущего до листа 1
4. Продолжайте, пока все дубликаты не будут перечислены с обеих рабочих таблиц Германии и Австрии на Лист1

У меня есть этот код, но проблема в том, что он собирает только дубликаты. Поэтому, если у меня есть 24 дубликата, на Листе 1 я хотел бы видеть их все из обеих таблиц Германии и Австрии, чтобы иметь возможность сравнивать всю другую информацию.

Мои данные в столбцах A: K. Я сравниваю данные по столбцу B.

Мой текущий код:

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")

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("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
ws3.Rows(1).Delete
Application.ScreenUpdating = True
End Sub

Answer 1

Я думаю, вам просто нужно добавить строку ниже к вашему l oop.

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
        'added line below
        ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, lc1)).Copy ws3.Range("A" & Rows.Count).End(3)(2)
        cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2)
    End If
Next cell