Deleting Duplicates

This should work (untested):
Sub DeleteRows()
for i=range("A65536").end(xlup) to 1 step -1
if application.countif(range("A:A"),cells(i,1).value)>1 then rows(i).delete
Next
End Sub

Hi

This will do the trick

Option Explicit

Sub DeleteDuplicates()

Application.ScreenUpdating = False

Dim x As Integer
Dim LastRow As Integer
Dim c As Range
Dim FirstAddress As String
Dim SearchValue As String
Dim Counter As Integer

LastRow = Range("A65536").End(xlUp).Row

For x = 1 To LastRow

SearchValue = Range("A" & x).Value

If SearchValue = "zzzdeletemezzz" Then
Else

With Range("A1:A" & LastRow)

Set c = .Find(what:=SearchValue, LookIn:=xlValues, lookat:=xlWhole)
FirstAddress = c.Address
Set c = .FindNext(c)

If c.Address = FirstAddress Then
Else
Range(c.Address).FormulaR1C1 = "zzzdeletemezzz"
Counter = Counter + 1
End If

End With

End If

Next x

x = 1

Do

If Range("A" & x).Value = "zzzdeletemezzz" Then
Rows(x).Delete
LastRow = LastRow - 1
Else
x = x + 1
End If

Loop While x < LastRow + 1

MsgBox (Counter & " duplicates have been deleted."), vbInformation, "Deletion Complete"

End Sub

HTH

Jacob

I'm sure Bob meant

For i = Range("A65536").End(xlUp).Row To 1 Step -1
If Application.CountIf(Range("A:A"), Cells(i, 1).Value) > 1 Then Rows(i).Delete
Next

as he mentioned (untested)

Ivan