Sub Extractor()
  Dim oRng As Range, oTable As Table, oCell As Cell, oNextCell As Cell
  Dim sFind As String, oRngCell As Range
  
  Set oTable = ActiveDocument.Tables(1)
  Set oRng = ActiveDocument.Range(oTable.Range.End, ActiveDocument.Range.End)
  For Each oCell In oTable.Columns(1).Cells
    sFind = Split(oCell.Range.Text, vbCr)(0)
    Set oRngCell = oCell.Next.Range
    With oRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = False
      Do While .Execute(FindText:=sFind)
        oRng.MoveStart Unit:=wdWord, Count:=-2
        oRng.MoveEnd Unit:=wdWord, Count:=4
        oRngCell.InsertBefore oRng & vbCr
        oRng.Collapse direction:=wdCollapseEnd
      Loop
      Set oRng = ActiveDocument.Range(oTable.Range.End, ActiveDocument.Range.End)
    End With
  Next oCell
End Sub