Update Macro Moving Dupe Records

[JADownie]

Hi,

I have the below code which works fine to identify duplicates. Currently it is moving 1 of the 2 duplicate records to the 'Duplicates' sheet but I would actually like it to move both of the duplicate records. I can't quite figure out how to tweak my code to accomplish that so any tips and advice would be greatly appreciated. Thanks!!



Dim Rng As Range, i As Long
Application.ScreenUpdating = False
Set Rng = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
For i = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountIf(Rng, Cells(i, "B")) > 1 Then
lr = Sheets("Duplicates").Cells(Rows.Count, "B").End(xlUp).Row + 1
Rows(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & lr)
Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Fluff]

How about

Sub MoveDupes()
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   Dim Cl As Range
   Dim Rng As Range
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws1.Range("B2", Ws1.Range("B" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl
         Else
            If Rng Is Nothing Then
               Set Rng = Union(Cl, .Item(Cl.Value))
            Else
               Set Rng = Union(Rng, Cl, .Item(Cl.Value))
            End If
         End If
      Next Cl
      If Not Rng Is Nothing Then
         Rng.EntireRow.Copy Ws2.Range("B" & Rows.Count).End(xlUp).Offset(1, -1)
         Rng.EntireRow.Delete
      End If
   End With
End Sub