Thanks OssieMac,
This works great.
Regards, Stan
"OssieMac" wrote in message
...
OK Stanley done. It just clears the cells now instead of deleting the
rows.
Have also modified a couple of other bits that makes the code more generic
therefore replace all of the code.

Sub RemoveDuplicates()

Dim rngToTest As Range
Dim rngTofind As Range
Dim cel As Range
Dim firstAddress As String
Dim i As Long
Dim rngSave As Range

With ActiveSheet
Set rngToTest = Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))

'Insert a temporary column to hold delete flag
.Columns("B:B").Insert Shift:=xlToRight

End With

Application.ScreenUpdating = False

For Each rngTofind In rngToTest

'Test if value already searched
With rngToTest
If rngTofind.Offset(0, 1) < "Delete" Then
Set cel = .Columns("A:A").Find(What:=rngTofind.Value, _
After:=.Cells(.Rows.Count, "A"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

Set rngSave = Nothing
If Not cel Is Nothing Then 'Found
firstAddress = cel.Address
Set rngSave = cel 'Save the location
Set cel = .FindNext(cel)
Do While Not cel Is Nothing And _
cel.Address < firstAddress
cel.Offset(0, 1) = "Delete"
rngSave.Font.Bold = True 'Bold original find
Set cel = .FindNext(cel)
Loop
End If
End If
End With
Next rngTofind

With rngToTest
'Work backwards when deleting rows
For i = .Rows.Count To 1 Step -1
If .Cells(i, 1).Offset(0, 1) = "Delete" Then
.Cells(i, 1).Clear
End If
Next i
End With

'Delete the temporary column
With ActiveSheet
.Columns("B:B").Delete
End With

Application.ScreenUpdating = True

End Sub


--
Regards,

OssieMac