Sub DeleteDuplicatesAnyCol()
Dim sht As Worksheet, sht2 As Worksheet
Dim rng As Range
Dim fndrng As Range
Dim mycell
Dim lookupcol As Integer, i As Integer
lookupcol = 1 ' for example Column E - replace with 1 if you want to
go with Column A
Set sht = ActiveSheet
Set rng = sht.Range(sht.Cells(1, lookupcol), sht.Cells(65536,
lookupcol).End(xlUp))
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set sht2 = Worksheets.Add
sht2.Name = "Deleted"
i = 1
sht.Activate
For Each mycell In rng.Cells
Set fndrng = rng.Find(mycell.Value, mycell, xlValues, xlWhole)
Do Until fndrng.Row = mycell.Row
sht.Rows(fndrng.Row).Copy Destination:=sht2.Rows(i)
i = i + 1
sht.Rows(fndrng.Row).Delete
Set fndrng = rng.FindNext(mycell)
Loop
Next mycell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub


I am trying to modify this code to pull in both of the duplicate rows
into the new worksheet "deleted". Currently it is only pulling in one
row. This would save me a bunch of time if it is possible. Thanks in
advance. -Michael