Sub Macro4()
'
' Macro4 Macro
' Macro recorded 26.03.2010
'

'
    Cells.Select
    With Selection.Interior
        .ColorIndex =  6 
        .Pattern = xlSolid
    End With
    Range("A1").Select
End Sub

Option Explicit

Sub ColoredDup()
Dim sht As Worksheet
Dim iLastRow As Long
Dim rr As Range, cc As Range, x As Range
Dim iFirstAddress$

Set sht = ThisWorkbook.Sheets( 1 )
iLastRow = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rr = Range(sht.Cells( 1 ,  1 ), sht.Cells(iLastRow,  1 ))
For Each cc In rr.Cells
If cc.Interior.ColorIndex =  6  Then
Set x = rr.Find(cc.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not x Is Nothing Then
iFirstAddress = x.Address
Do
Set x = rr.FindNext(x)
sht.Cells(x.Row, x.Column).Interior.ColorIndex =  6 
Loop While Not x Is Nothing And x.Address <> iFirstAddress
End If
End If
Next

End Sub

cc.Value = Application.WorksheetFunction.Trim(cc.Value) ' будут удаляться лидирующие и финиширующие пробелы, а также многократные пробелы между словами (исползуется стандартная функция СЖПРОБЕЛЫ)