8
\$\begingroup\$

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

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
\$\endgroup\$
  • \$\begingroup\$ This did the trick. It brought the time to run this function from 16 seconds down to 1 second. \$\endgroup\$ – Kelly Tessena Keck Jul 18 '16 at 14:34
  • \$\begingroup\$ 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. \$\endgroup\$ – Kelly Tessena Keck Jul 20 '16 at 17:41
7
\$\begingroup\$

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
\$\endgroup\$
  • 2
    \$\begingroup\$ Where's idea #2? \$\endgroup\$ – Mathieu Guindon Jul 15 '16 at 16:39
  • 1
    \$\begingroup\$ @Mat'sMug Why don't you provide it :p \$\endgroup\$ – Kaz Jul 15 '16 at 17:21
  • 1
    \$\begingroup\$ @KellyTessenaKeck That's not going to help. The only reason mapping is faster is if you get to re-use the map. If you have to re-map every time you call the search function, then you may as well stick with the current version. I'll see what else I can come up with. \$\endgroup\$ – Kaz Jul 15 '16 at 17:22
  • 1
    \$\begingroup\$ @KellyTessenaKeck maybe. But can you guarantee that that will always be true everywhere in your document every time you try to do this? \$\endgroup\$ – Kaz Jul 15 '16 at 17:43
  • 2
    \$\begingroup\$ And hey, 16 seconds for something you do once a week is insignificant, but 16 seconds * 100's of times does start to add up. There'll be a way to do it. \$\endgroup\$ – Kaz Jul 15 '16 at 17:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.