Sub xx() Dim ToFind As Range, wFind As Range, cel As Range, rToFind As Long Dim rD As Long, rE As Long, c As Object, firstAddress As String rD = Range("D" & Rows.Count).End(xlUp).Row rE = Range("E" & Rows.Count).End(xlUp).Row If rD >= rE Then rToFind = rD Else rToFind = rE Set ToFind = Range("D1:E" & rToFind) Set wFind = Range("A:A") For Each cel In ToFind If Not IsEmpty(cel.Value) Then With wFind Set c = .Find(cel.Value, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Range(c.Address).Interior.ColorIndex = 4 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With End If Next cel Set ToFind = Nothing Set wFind = Nothing Set c = Nothing End Sub