Macro to Create a Table from a Find String

[gmaxey]

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Range
Dim arrFound() As String
Dim oDoc As Document, oTbl As Word.Table
Dim lngIndex As Long
  ReDim arrFound(1, 0)
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Format = True
    .Font.Bold = True
    .Font.Underline = wdUnderlineDouble
    While .Execute
      
      arrFound(0, UBound(arrFound, 2)) = oRng.Text
      arrFound(1, UBound(arrFound, 2)) = oRng.Information(wdActiveEndPageNumber)
      ReDim Preserve arrFound(1, UBound(arrFound, 2) + 1)
      oRng.Collapse wdCollapseEnd
    Wend
  End With
  ReDim Preserve arrFound(1, UBound(arrFound, 2) - 1)
  Set oDoc = Documents.Add
  Set oTbl = oDoc.Tables.Add(oDoc.Range, UBound(arrFound, 2) + 1, 2)
  For lngIndex = 0 To UBound(arrFound, 2)
    oTbl.Cell(lngIndex + 1, 1).Range.Text = arrFound(0, lngIndex)
    oTbl.Cell(lngIndex + 1, 2).Range.Text = arrFound(1, lngIndex)
  Next
lbl_Exit:
  Exit Sub
  
End Sub