try:

Sub Test()
Dim LRow As Long, i As Long, n As Long
Dim varOut() As Variant

Application.ScreenUpdating = False
With ActiveSheet
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim Preserve varOut(LRow - 1, 1)
For i = 1 To LRow
With Application
varOut(n, 0) = .Cells(i, 1).Value
varOut(n, 1) = .CountIf(.Range("A1:A" & LRow), .Cells(i, 1))
n = n + 1
End With
Next
For i = UBound(varOut) To LBound(varOut) Step -1
If varOut(i, 1) 1 Then
.Rows(i + 1).Delete
End If
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus B.

Great stuff, nice as can be.

Thanks Claus.

Howard