Cerca con Macro

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