比較兩個工作表並使用兩者的重復項構建新工作表

Question

我正在嘗試構建一個代碼來比較兩個工作表並將重復項收集到另一個工作表。 目標是：

1. 檢測重復
2. 將重復行從工作表德國復制到 Sheet1
3. 從下面的工作表奧地利復制重復的行到 Sheet1
4. 繼續，直到從工作表德國和奧地利到工作表 1 中列出所有重復項

我有這個代碼，但問題是它只收集重復項。 因此，如果我總共有 24 個重復項，則在 Sheet1 上，我希望從德國和奧地利工作表中看到所有這些重復項，以便能夠比較所有其他信息。

我的數據在 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

我認為您只需要將下面的行添加到您的循環中。

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