Sub kos20()
Dim x
  For Each x In Range("H1:H3").Value 'массив искомых слов в H1:H3
                                     'массив текста в 1 столбце
    Columns(1).Replace What:="*" & x & "*", Replacement:=x, _
        LookAt:=xlWhole, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
  Next
End Sub

Sub kos20()
Dim x
  columns(1).copy columns(2)
  For Each x In Range("H1:H3").Value 'массив искомых слов в H1:H3
                                     'массив текста в 1 столбце, массив результатов во 2 столбце
    Columns(2).Replace What:="*" & x & "*", Replacement:=x, _
        LookAt:=xlWhole, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
  Next
End Sub

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