I've not looked at your examples (no time at the mo) but just dashed this off, it should work for what you seem to require:
Code:
Sub Extract_Words()
Dim rng As Range, MyCell As Range
Dim IB As String, INo As Long, i As Long, fVal As Long
INo = Application.InputBox("Enter Number of words to find", "Word Count")
For i = 1 To INo
IB = Application.InputBox("Enter word number " & i, "Word Finder")
Set rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each MyCell In rng
On Error Resume Next
fVal = Application.WorksheetFunction.Find(IB, MyCell.Value, 1)
If Mid(MyCell.Value, fVal, Len(IB)) = IB Then
MyCell.Offset(0, 1) = MyCell.Offset(0, 1).Value & " " & IB
End If
Next MyCell
Next i
End Sub
Bookmarks