Поиск текста в тексте

Sub dddd()

For Each r In Range("h3:h4")


With Range("D1:D100")
    Set c = .Find("*" & r.Value & "*", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Range("F" & c.Row) = r.Value
        Do
'            c.Value = 5
            Set c = .FindNext(c)
            Debug.Print c.Address
            Range("F" & c.Row) = r.Value
        Loop While Not c Is Nothing And c.Address  firstAddress
    End If
End With


Next r
End Sub