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.