Sub Macro1()
Dim vFindText As Variant
Dim oRng As Range
Dim oColl As Collection
Dim oSource As Document, oTarget As Document
Dim i As Long, j As Integer
    Set oSource = ActiveDocument
    Set oTarget = Documents.Add
    Set oColl = New Collection
    vFindText = Array("SHIM", "WORD2", "WORD3")    'list the words or phrases to find
    For i = 0 To UBound(vFindText)
        Set oRng = oSource.Range
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(FindText:=vFindText(i) & "[ .0-9]{1,}", _
                              MatchWildcards:=True)
                oTarget.Range.InsertAfter oRng.Text & vbCr
                oRng.Collapse wdCollapseEnd
            Loop
        End With
    Next i
lbl_Exit:
    Exit Sub
End Sub

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oTbl As Table
Dim arrTerm() As String
Dim lngIndex As Long
Dim oRng As Range

  Set oTbl = ActiveDocument.Tables(1)
  ReDim arrTerm(oTbl.Rows.Count - 2, 1)
  For lngIndex = 2 To oTbl.Rows.Count
    arrTerm(lngIndex - 2, 0) = fcnGetCellText(oTbl.Cell(lngIndex, 1))
    arrTerm(lngIndex - 2, 1) = fcnGetCellText(oTbl.Cell(lngIndex, 2))
  Next lngIndex
  For lngIndex = 0 To UBound(arrTerm, 1)
    Set oRng = ActiveDocument.Range
    oRng.Start = oTbl.Range.End
    With oRng.Find
      .Text = arrTerm(lngIndex, 0)
      If .Execute Then
         Select Case True
           Case IsNumeric(arrTerm(lngIndex, 1))
              oRng.Collapse wdCollapseEnd
              oRng.MoveEnd wdWord, Val(arrTerm(lngIndex, 1)) + 1
              oTbl.Cell(lngIndex + 2, 3).Range.Text = Trim(oRng.Text)
           Case arrTerm(lngIndex, 1) = "T/F"
             oTbl.Cell(lngIndex + 2, 3).Range.Text = "True"
         End Select
      Else
        Select Case True
           Case IsNumeric(arrTerm(lngIndex, 1))
             oTbl.Cell(lngIndex + 2, 3).Range.Text = vbNullString
           Case arrTerm(lngIndex, 1) = "T/F"
             oTbl.Cell(lngIndex + 2, 3).Range.Text = "False"
         End Select
      End If
    End With
  Next lngIndex
lbl_Exit:
  Exit Sub
  
End Sub
Function fcnGetCellText(oCell As Cell) As String
  fcnGetCellText = Left(oCell.Range.Text, Len(oCell.Range.Text) - 2)
lbl_Exit:
  Exit Function
End Function

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

Sub Macro1()
Dim vFindText As Variant
Dim oRng As Range
Dim oTable As Table
Dim oCell As Range
Dim oDoc As Document
Dim i As Long, j As Integer
    vFindText = Array("AUA", "SHIM", "PSA", "TURBT", "Frequency")
    Set oDoc = ActiveDocument
    oDoc.Range.InsertParagraphBefore
    Set oRng = oDoc.Range
    oRng.Collapse 1
    Set oTable = oDoc.Tables.Add(oRng, 5, 2)
    For i = 0 To 4
        Set oRng = oDoc.Range
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(FindText:=vFindText(i))
                Select Case i
                    Case 0, 1, 2
                        oRng.MoveEndUntil "0123456789"
                        oRng.Collapse 0
                        oRng.MoveEndWhile "0123456789/."
                        Set oCell = oTable.Cell(i + 1, 1).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = vFindText(i)
                        Set oCell = oTable.Cell(i + 1, 2).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = oRng.Text
                    Case Else
                        Set oCell = oTable.Cell(i + 1, 1).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = vFindText(i)
                        Set oCell = oTable.Cell(i + 1, 2).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = True
                End Select
            Loop
        End With
    Next i
lbl_Exit:
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oTable = Nothing
    Set oCell = Nothing
    Exit Sub
End Sub