Sub ExtractWords()
Dim oDoc As Document
Dim oSource As Document
Dim oRng As Range
Dim Coll As Collection
Dim i As Long
    Set oSource = ActiveDocument
    Set oRng = oSource.Range
    Set Coll = New Collection
    With oRng.Find
        .Highlight = True
        Do While .Execute
            On Error Resume Next
            Coll.Add oRng.Text, oRng.Text
            oRng.Collapse 0
        Loop
    End With
    If Coll.Count > 0 Then
        Set oDoc = Documents.Add
        For i = 1 To Coll.Count
            oDoc.Range.InsertAfter Coll(i) & vbCr
        Next i
    End If
lbl_Exit:
    Set oDoc = Nothing
    Set oSource = Nothing
    Set oRng = Nothing
    Set Coll = Nothing
    Exit Sub
End Sub