Private Sub CommandButton1_Click()
Dim Rng As Range, sRng As Range, Cls As Range
Dim eRw As Long, MyAdd As String
Columns("B:D").Interior.ColorIndex = 2
eRw = [B65500].End(xlUp).Row
Set Rng = Range("B5:B" & eRw)
For Each Cls In Rng(2).Resize(eRw - 1)
Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
If MyAdd <> sRng.Address Then
sRng.Resize(, 3).Interior.ColorIndex = 38
Range(MyAdd).Resize(, 3).Interior.ColorIndex = 42
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And MyAdd <> sRng.Address
End If
Next Cls
End Sub