Word VBA function to find a specified heading & return its text as a string

Question

In this post, I asked for an overall review of a script to auto-generate table captions, because it was running relatively slowly. I've used Debug.Print to isolate the problem, and this function takes the longest (at 16 seconds).

The purpose of the function is to find the heading of a specified style that the selected text falls under. It loops back through each paragraph to see if it's the right style. When it finds it, it returns the paragraph text as a string (which the larger script uses to generate the table caption).

Any suggestions for improvement are welcome, but I'd specifically like performance improvement suggestions, as well as feedback on how long a function like this should take (i.e., is it slow or am I just impatient?)

Public Function FindHeading(strHeadLevel As String) As String
'Gets the heading level as an input and finds the closest heading of that level before the selection.

    Dim rngSelection As Range
    'the initial selection

    Dim rngPrev As Range
    'The current paragraph to be evaluated.

    Set rngSelection = Selection.Range
    Set rngPrev = rngSelection.Previous(wdParagraph, 1)

    'MsgBox (rngPrev.Text)

    Do While rngPrev.Style <> strHeadLevel

        If ActiveDocument.Range(0, rngPrev.Paragraphs(1).Range.End).Paragraphs.Count > 1 Then
            Set rngPrev = rngPrev.Previous(wdParagraph, 1)
            'MsgBox ("rngPrev Style =  " & rngPrev.Style & vbCr & "Text = " & rngPrev.Text)
        Else
            'MsgBox ("Heading not found")
            Exit Do
        End If

    Loop

    If rngPrev.Style = strHeadLevel Then
        FindHeading = rngPrev.Paragraphs(1).Range.Text
    Else
        FindHeading = "No heading found"
    End If

End Function

Answer 1

No need for a loop at all; just use Word's built-in ability to find text based on its style and other formatting.

Like so:

Public Function FindHeading(strHeadLevel As String) As String
    Dim rng As Range

    'set a range to the selection first so we can avoid
    '  the selection jumping around as we do our find
    Set rng = Selection.Range

    With rng.Find
        'set up our find criteria
        .ClearAllFuzzyOptions
        .ClearHitHighlight
        .ClearFormatting
        .Text = ""
        'search from current location back to start of document
        .Forward = False
        'and stop when we hit the start
        .Wrap = wdFindStop
        'here's the important part
        .Format = True
        .Style = strHeadLevel

        'now do our find
        If .Execute Then
            '.Parent contains the found range
            Set rng = .Parent
            'strip off trailing paragraph mark
            rng.MoveEnd unit:=wdCharacter, Count:=-1
            'grab the text of the found range
            FindHeading = rng.Text
        Else
            'we ain't got nothing
            FindHeading = "No heading found"
        End If
    End With
End Function

Answer 2

First things first, let's clean everything up.

---

Proper descriptive naming, proper validation variables, making the code clear and obvious about what's happening where

Public Function GetHeadingFromStyle(ByVal styleToFind As String) As String
    '/ Iteratively checks the style of all paragraphs, starting at the current selection and working towards the start of the document.
    '/ If the style matches the inputStyle, return the text of the paragraph.
    '/ If no match is found, return "No heading Found"

    Const NO_HEADING_FOUND_TEXT As String = "No heading Found"

    Dim currentRange As Range
    currentRange = Selection.Range

    Dim wholeDocumentSearched As Boolean
    wholeDocumentSearched = False

    Dim headingFound As Boolean
    headingFound = False

    Do Until headingFound Or wholeDocumentSearched
        Set currentRange = currentRange.Previous(wdParagraph, 1)

        headingFound = (currentRange.Style = styleToFind)
        wholeDocumentSearched = ActiveDocument.Range(0, currentRange.Paragraphs(1).Range.End).Paragraphs.Count = 0
    Loop

    If headingFound Then
        GetHeadingFromStyle= currentRange.Paragraphs(1).Range.Text
    Else
        GetHeadingFromStyle= NO_HEADING_FOUND_TEXT
    End If

End Function

---

Okay, here's where we're taking so much time:

Do Until headingFound Or wholeDocumentSearched
    Set currentRange = currentRange.Previous(wdParagraph, 1)

    headingFound = (currentRange.Style = styleToFind)
    wholeDocumentSearched = ActiveDocument.Range(0, currentRange.Paragraphs(1).Range.End).Paragraphs.Count = 0
Loop

You mentioned in your previous question that these documents could be 1,000+ pages. Iteratively looping over something that huge is going to be slow. What we need is some kind of map/lookup.

---

I'm not very familiar with the Word object model, so there might be something blindingly obvious/easy I'm missing. That aside, here are ideas:

---

Idea #1:

Map the entire document once and then reference the map. This will mean having a slow execution once, and then all subsequent searches should be lightning fast.

Note, this only works if the document structure is not going to change between some number of iterations (5-10 would be a good minimum). Because as soon as a new paragraph gets inserted/deleted/moved, our entire map is going to be inaccurate.

So, something like this:

Option Explicit

Public ParagraphStyles As Variant
Public Const INDEX_INDEX2 As Long = 1 '/ index2 to distinguish between dimensions of the array
Public Const STYLE_INDEX2 As Long = 2

Public Sub SetupDocumentSearch()

    ParagraphStyles = MapParagraphStyles

    '/ Call Main sub here

End Sub

Public Function MapParagraphStyles(ByRef targetDocument As Document)
    '/ Loop through the document and, for each paragraph:
    '/ Add the paragraph Index and Style to an array

    With targetDocument

        Dim styleMap As Variant
        ReDim styleMap(1 To .Paragraphs.Count, 1 To 2)

        Dim currentParagraph As Range
        Dim paragraphCounter As Long

        For paragraphCounter = 1 To .Paragraphs.Count

            styleMap(paragraphCounter, INDEX_INDEX2) = indexcounter
            styleMap(paragraphCounter, STYLE_INDEX2) = .Paragraphs(indexcounter).Style

        Next paragraphCounter

    End With

    MapParagraphStyles = styleMap

End Function

Then we can loop over an array searching for our style. Iterating over arrays is orders of magnitude faster than working with high-level objects like documents:

Public Function GetHeadingFromStyle(ByVal styleToFind As String) As String
    '/ Iteratively checks the style of all paragraphs, starting at the current selection and working towards the start of the document.
    '/ If the style matches the inputStyle, return the text of the paragraph.
    '/ If no match is found, return "No heading Found"

    Const NO_HEADING_FOUND_TEXT As String = "No heading Found"

    Dim paragraphIndex As Long
    paragraphIndex = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count

    Dim wholeDocumentSearched As Boolean
    wholeDocumentSearched = False

    Dim headingFound As Boolean
    headingFound = False

    Do Until headingFound Or wholeDocumentSearched
        paragraphIndex = paragraphIndex - 1

        headingFound = ParagraphStyles(paragraphIndex, STYLE_INDEX2) = styleToFind
        wholeDocumentSearched = (paragraphIndex = 1)
    Loop

    If headingFound Then
        GetHeadingFromStyle = ActiveDocument.Paragraphs(paragraphIndex).Range.Text
    Else
        GetHeadingFromStyle = NO_HEADING_FOUND_TEXT
    End If

End Function