Get heading information using a wild card search loop in MS Word using VBA

Question

I am doing a wildcard search loop in MS Word and generating the list of all the find values in a new document using following code. I have added page numbers to the output. But I can't think of how to get the headers for the searched output. Pls suggest.

Sample Word Document:

1 Heading
Text Text Text Text Text

--<Page Break>--

1.1 Heading
Text Text Text Text Text [Reference X1]

1.1.1 Heading
Text Text Text Text Text
Text Text Text Text Text
Text Text Text Text Text

--<Page Break>--

1.2 Heading
Text Text Text Text Text

1.2.1 Heading
Text Text Text Text Text
Text Text Text Text Text [Reference X2]
Text Text Text Text Text [Reference X3]

The 1, 1.1, etc headings are the default heading styles used in MS word. (For me the style name is "Heading 1", "Heading 2", etc.)

The output I am expecting is as under in a tabular format:

| Reference     | Heading        | Page  |
| Reference X1  | 1.1 Heading    | 2     |
| Reference X2  | 1.2.1 Heading  | 3     |
| Reference X2  | 1.2.1 Heading  | 3     |

The Code (part of the sub that does this finding and writing in the table) I have been able to write so far is:

With oDoc
    Set oRange = .Range
    n = 1
    With oRange.Find
        .Text = "<Reference X[0-9]{1,}>"
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            strFound = oRange
            With oTable
                .Cell(n+1,1).Range.Text = strFound
                .Cell(n+1,3).Range.Text = oRange.Information(wdActiveEndPageNumber)
            End With
            n = n + 1
        Loop
    End With
End With

I already have the code for defining these variables, creating a table and required rows in it. I am only confused about how to get the heading just above the found item. The issue is there can be one or multiple "Reference XX" under one heading. Further, the heading level can be any. And I need separate rows for each item found using the wildcard.

Answer 1

For example:

Sub GetRefHeadings()
Application.ScreenUpdating = False
Dim Rng As Range, StrOut As String, Tbl As Table
StrOut = "Ref." & vbTab & "Heading" & vbTab & "Page" & vbCr
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<Reference X[0-9]@>"
    .Replacement.Text = ""
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    Set Rng = .Paragraphs(1).Range
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    StrOut = StrOut & .Text & vbTab & Rng.Paragraphs.First.Range.ListFormat.ListString & _
      " " & Split(Rng.Text, vbCr)(0) & vbTab & Rng.Information(wdActiveEndPageNumber) & vbCr
  Loop
End With
Set Rng = ActiveDocument.Range.Characters.Last
Rng.Text = StrOut
Set Tbl = Rng.ConvertToTable(Separator:=vbTab)
With Tbl
  .PreferredWidthType = wdPreferredWidthPercent
  .PreferredWidth = 100
  .Columns.PreferredWidthType = wdPreferredWidthPercent
  .Columns(1).PreferredWidth = 20
  .Columns(2).PreferredWidth = 70
  .Columns(3).PreferredWidth = 10
  .Rows(1).Range.Font.Bold = True
  .Rows(1).HeadingFormat = True
  '.Sort ExcludeHeader:=True, FieldNumber:=1
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub

If you want the found text's page # instead of the heading's page #, change Rng.Information to .Information.

The default sort order is by reference found, regardless of the Reference #, which coincides with sorting by Heading. The code also includes a commented-out line to sort by Reference # instead.

Answer 2

You can find the heading level of the section of text you've found using a predefined bookmark. Since this trick uses the Selection object, you have to transfer the "found text" range to Selection. This code snippet below shows how:

Option Explicit

Sub test()
    With ActiveDocument
        Dim foundThis As Range
        Set foundThis = .Range
        With foundThis.Find
            .Text = "<Reference X[0-9]{1,}>"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                Dim strFound As String
                Dim heading As String
                strFound = foundThis.Text
                heading = foundThis.GoTo(What:=wdGoToBookmark, _
                                         Name:="\HeadingLevel").Paragraphs(1).Range.Text
                Debug.Print "string found: " & strFound & " on page " & _
                            foundThis.Information(wdActiveEndPageNumber) & _
                            ", Heading: " & heading
            Loop
        End With
    End With
End Sub