Here is my find method.
Sub Test_FoundRanges() Dim f As Range, ff As Range, r As Range
Set r = Range("A1:B3")
For Each f In r
Set ff = FoundRanges(r, f.Value2)
If Not ff Is Nothing And f.Value2 <> "" Then _
If ff.Cells.Count >= 2 Then f.Interior.Color = vbRed
Next f
End Sub
Function FoundRanges(fRange As Range, fStr As String) As Range
Dim objFind As Range
Dim rFound As Range, FirstAddress As String
With fRange
Set objFind = .Find(what:=fStr, After:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=True)
If Not objFind Is Nothing Then
Set rFound = objFind
FirstAddress = objFind.Address
Do
Set objFind = .FindNext(objFind)
If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
End If
End With
Set FoundRanges = rFound
End Function