Próbuję zbudować kod, który porówna dwa arkusze i zbierze duplikaty do innego arkusza. Celem jest:

  1. Wykryj duplikat
  2. Skopiuj zduplikowany wiersz z arkusza roboczego Niemcy do Arkusza1
  3. Skopiuj zduplikowany wiersz z arkusza roboczego Austria poniżej przed Sheet1
  4. Kontynuuj, aż wszystkie duplikaty zostaną wymienione z obu arkuszy roboczych w Niemczech i Austrii do Arkusza1

Mam ten kod, ale problem w tym, że zbiera tylko duplikaty. Więc jeśli mam w sumie 24 duplikaty, na Arkuszu 1 chciałbym zobaczyć je wszystkie z obu arkuszy roboczych w Niemczech i Austrii, aby móc porównać wszystkie inne informacje.

Moje dane znajdują się w kolumnach A: K. Porównuję dane według kolumny B.

Mój obecny kod:

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
1
hatman 14 styczeń 2020, 18:54

1 odpowiedź

Najlepsza odpowiedź

Myślę, że wystarczy dodać poniższą linię do swojej pętli.

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
1
SJR 14 styczeń 2020, 16:06