Sub Demo()
Dim Rc As Range
Application.ScreenUpdating = False
With Feuil1.[B4].CurrentRegion
For R& = 1 To .Rows.Count - 1
If .Cells(R).Interior.ColorIndex = xlNone Then
Set Rc = .Find(-.Cells(R).Value, .Cells(R), xlValues, xlWhole)
If Not Rc Is Nothing Then
N& = Rc.Row
Do
If Rc.Interior.ColorIndex = xlNone Then
Rc.Interior.ColorIndex = 40
.Cells(R).Interior.ColorIndex = 40
Exit Do
End If
Set Rc = .FindNext(Rc)
Loop While Rc.Row > N
End If
End If
Next
End With
Set Rc = Nothing
Application.ScreenUpdating = True
End Sub