I misunderstood
This should be better
Option Explicit
Sub SearchWords()
Dim rCell As Range, rFind As Range, rSearch As Range
Dim vFind As Variant, vTemp As Variant
Dim iFind As Long
Dim sFind As String, sSearch As String
'if range not selected then get out
If Not TypeOf Selection Is Range Then Exit Sub
Set rFind = Worksheets("Words to find").Cells(1, 1).CurrentRegion
Set rFind = rFind(2, 1).Resize(rFind.Rows.Count - 1, 1)
sFind = Join(Application.WorksheetFunction.Transpose(rFind), "#")
vFind = Split(sFind, "#")
For Each rCell In Selection.Columns(1).Cells
sSearch = UCase(rCell.Text)
If Right(sSearch, 1) = "." Then sSearch = Left(sSearch, Len(sSearch) - 1)
For iFind = LBound(vFind) To UBound(vFind)
If InStr(sSearch, UCase(vFind(iFind))) > 0 Then
rCell.Offset(0, 1).Value = rCell.Offset(0, 1).Value & vFind(iFind) & ";"
End If
Next iFind
'remove last added ";"
If Len(rCell.Offset(0, 1)) > 0 Then rCell.Offset(0, 1).Value = Left(rCell.Offset(0, 1), Len(rCell.Offset(0, 1)) - 1)
Next
End Sub