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

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
Exit Do
End If

Loop

If rngPrev.Style = strHeadLevel Then
Else
End If

End Function

• Nice to see you back ^^ I still have no idea about the Word Object Model but I'll try to give it a go. – Kaz Jul 15 '16 at 15:31
• Not sure if it's a copy and paste problem, but everything within the function should be indented. – pacmaninbw Jul 15 '16 at 15:45
• @pacmaninbw nope, that's just how the code looked in the original quesiton too. – Kaz Jul 15 '16 at 15:47
• That's how it is in the original. I can fix that. – Kelly Tessena Keck Jul 15 '16 at 16:08

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

'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
Else
'we ain't got nothing
End If
End With
End Function

• This did the trick. It brought the time to run this function from 16 seconds down to 1 second. – Kelly Tessena Keck Jul 18 '16 at 14:34
• I also noticed that the really big time sucks weren't anything the code itself was doing but Word repaginating and updating fields. Switching to Draft mode and locking all fields made a big difference, but those types of things are more relevant to Super User than here. – Kelly Tessena Keck Jul 20 '16 at 17:41

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

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

Else
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

Do Until headingFound Or wholeDocumentSearched
paragraphIndex = paragraphIndex - 1

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