Macro to Create a Table from a Find String

[mike_302]

Hello,

I have built one macro already, to give a special format to any string of a certain format -- "(" followed by a number and a letter, followed by ")". The format that is applied is unique: bold and double-underline. Now I would like one more macro that will go a step further. It will search the document and identify any instance of bold and double-underlined text. It will put the found string in a cell, and identify which page it occurs on in the adjacent cell (See example below).

Example Table Output

(1A)	2
(2C)	2
(1B)	4

The table can be in Excel or it can be in a new word document -- that doesn't matter to me too much.

Can anyone guide me on this task? I am quite a VBA noob, sadly. I could've done something like this in MATLAB, but nowhere near good enough with VBA to make this happen. I hope that doesn't scare anyone away from volunteering some help.

[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

[mike_302]

WOW! That seems like you hardly had to think about it...

I've already tried to go through the code to understand it, based on my knowledge of how I might program something like it in MATLAB, but it's VERY different syntax, and I'm thrown off quite a bit.

Thanks though -- I ran the code and it worked exactly as detailed.

[gmaxey]

The array probably made it more complicated than needed, but you could write that array to an Excel range.

Here is another way:

Sub ScratchMacroII()
'A basic Word macro coded by Greg Maxey
Dim oRng As Range
Dim oDoc As Document, oDocTarget As Document, oTbl As Word.Table
  Set oDoc = ActiveDocument
  'Create the target document.
  Set oDocTarget = Documents.Add
  'Create the target basic table.
  Set oTbl = oDocTarget.Tables.Add(oDocTarget.Range, 1, 2)
  oDoc.Activate
  Set oRng = oDoc.Range
    With oRng.Find
      .Format = True
      .Font.Bold = True
      .Font.Underline = wdUnderlineDouble
      Do While .Execute
        'For each found bit of text add the text and page found to the table.
        oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = oRng.Text
        oTbl.Cell(oTbl.Rows.Count, 2).Range.Text = oRng.Information(wdActiveEndPageNumber)
        'Add a new target row.
        oTbl.Rows.Add
        oRng.Collapse wdCollapseEnd
        If oRng.End = oDoc.Range.End Then Exit Do
      Loop
    End With
    oTbl.Rows.Last.Delete
lbl_Exit:
  Exit Sub
End Sub

[mike_302]

The comments in this are extra helpful. I made a small modification, only to match the page numbers up with the actual page numbers (I have unnumbered pages at the beginning of the document). I really appreciate this! Thanks again.