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