Remove all duplicates to new sheet

[Sharid]

Hi

My code below removes duplicates to a new sheet, however I need it to do a bit more which I can not work out and have been stuck on for a few days.

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

Sheet 1
Has a data table, I want it to find the duplicates in column D and move them and the original record . So the data will show like this in the new Sheet called "Dup" BELOW

From This
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name
[/TD]
[TD]Age
[/TD]
[/TR]
[TR]
[TD]John
[/TD]
[TD]20
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]20
[/TD]
[/TR]
[TR]
[TD]Peter
[/TD]
[TD]18
[/TD]
[/TR]
[TR]
[TD]Mike
[/TD]
[TD]25
[/TD]
[/TR]
[TR]
[TD]Bob
[/TD]
[TD]17
[/TD]
[/TR]
[TR]
[TD]Sam
[/TD]
[TD]18
[/TD]
[/TR]
[TR]
[TD]David
[/TD]
[TD]26
[/TD]
[/TR]
[TR]
[TD]Mary
[/TD]
[TD]20
[/TD]
[/TR]
[TR]
[TD]Paul
[/TD]
[TD]19
[/TD]
[/TR]
</tbody>[/TABLE]


Sheet2 is called Dup
All duplicate records have been removed along with the original. Duplicates records NOW are to show in RED and Original (First record) to show in Black

To This
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name
[/TD]
[TD]Age
[/TD]
[/TR]
[TR]
[TD]John
[/TD]
[TD]20
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]20
[/TD]
[/TR]
[TR]
[TD]Mary
[/TD]
[TD]20
[/TD]
[/TR]
[TR]
[TD]Peter
[/TD]
[TD]18
[/TD]
[/TR]
[TR]
[TD]Sam
[/TD]
[TD]18
[/TD]
[/TR]
</tbody>[/TABLE]

Sheet 1
Now looks like this

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name
[/TD]
[TD]Age
[/TD]
[/TR]
[TR]
[TD]Mike
[/TD]
[TD]25
[/TD]
[/TR]
[TR]
[TD]Bob
[/TD]
[TD]17
[/TD]
[/TR]
[TR]
[TD]David
[/TD]
[TD]26
[/TD]
[/TR]
[TR]
[TD]Paul
[/TD]
[TD]19
[/TD]
[/TR]
</tbody>[/TABLE]


Thanks

 

[Fluff]

How about

Sub sharid()
   Dim Cl As Range, Rng As Range
   Application.ScreenUpdating = False
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("D1:D" & Range("D" & Rows.Count).End(xlUp).Row)
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl
         Else
            Cl.EntireRow.Font.Color = vbRed
            If Rng Is Nothing Then Set Rng = Union(Cl, .Item(Cl.Value)) Else Set Rng = Union(Rng, Cl, .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then
      Rng.EntireRow.Copy Sheets("Dup").Range("D" & Rows.Count).End(xlUp).Offset(1, -3)
      Rng.EntireRow.Delete
   End If
End Sub

 

[Sharid]

Fluff, this is super. As always you have saved my life once again

 

[Fluff]

You're welcome & thanks for the feedback