# Macro for inserting a mini table between heading styles

I am using the following macro to insert a mini table of contents between two identical heading styles (e.g. Heading 1). It works fine on small documents, but is very slow on large documents.

Sub MiniTOCFields(HeadingNumber As Long, TOCLevel As Long)
' Add mini TOC fields after all occurrences of a Heading style.
' TOCLevel defines to what heading level the TOC shows (e.g. down to Heading 3).

Dim bookmarkNumber As Long
Dim bookmarkRange As Range
Dim insertRange As Range
Dim currentParagraph As Paragraph
Dim paragraphNumber As Long
Dim currentTOC As TableOfContents

bookmarkNumber = 0
paragraphNumber = 0

Set bookmarkRange = ActiveDocument.Paragraphs(1).Range

' Cycle through each paragraph
For Each currentParagraph In ActiveDocument.Paragraphs
paragraphNumber = paragraphNumber + 1

' Check for occurrences of Heading X

' If this is not the first occurrence, create a bookmark between this and the last one
If bookmarkNumber > 0 Then
' Move the end of the bookmark to the end of the next paragraph
bookmarkRange.End = ActiveDocument.Paragraphs(paragraphNumber - 1).Range.End
' Create bookmark
Range:=bookmarkRange
End If

' Move the start of the bookmark to the beginning of the next paragraph
bookmarkRange.Start = ActiveDocument.Paragraphs(paragraphNumber + 1).Range.Start

Set insertRange = currentParagraph.Range
insertRange.Collapse direction:=wdCollapseEnd
' Add the new TOC field
Range:=insertRange, _
Type:=wdFieldEmpty, _
Text:=" TOC \h \o """ & HeadingNumber & "-" & TOCLevel & """ \b TOCHeading" & HeadingNumber & "_" & (bookmarkNumber + 1)
bookmarkNumber = bookmarkNumber + 1
End If

' Check for last paragraph and bookmark
If paragraphNumber = ActiveDocument.Paragraphs.Count Then
' Move the end of the bookmark to the end of this paragraph
bookmarkRange.End = currentParagraph.Range.End
' Create bookmark
Range:=bookmarkRange
bookmarkNumber = bookmarkNumber + 1
End If

Next currentParagraph

' Update all TOC fields in document
For Each currentTOC In ActiveDocument.TablesOfContents
currentTOC.Range.Select
currentTOC.Update
Next currentTOC

End Sub

• Is it the paragraph loop or the TOC updates that take too long? I don't think you need the .Range.Select call, just .Update should be enough to update the currentTOC. – Mathieu Guindon Jun 11 '14 at 23:29
• The paragraph loop takes the bulk of the time. The TOC update is fairly quick. Thanks for the feedback. – David Jun 13 '14 at 3:09

## Optimization:

You've done a good job of making sure you're not processing more than you have to, but there are a couple of things you can do here to improve performance. Instead of looping through all of the MiniTOCs you've just inserted, updating each one individually. Just update all of the fields in the entire document at once.

Replace This:

' Update all TOC fields in document
For Each currentTOC In ActiveDocument.TablesOfContents
currentTOC.Range.Select
currentTOC.Update
Next currentTOC


With This:

ActiveDocument.Fields.Update


It also turns out that there's no reason to to check every paragraph's style. We can find them all. Below is the uber simplified logic that you would need to implement. Also note that subs/functions should have a verb-noun type name. I changed it in my example.

Private Sub test()
End Sub

Public Sub InsertMiniTOCFields(headingStyle As WdBuiltinStyle, TOClevel As Long)
Dim bookmarkRange As Range
Dim bookmarkNumber As Long
Dim currentRange As Range
Dim insertRange As Range
Dim doc As Document

Set doc = ActiveDocument
Set currentRange = doc.Range 'start with the whole doc as the current range

With currentRange.Find
.Forward = True         'move forward only
.Style = headingStyle   'the style given as an argument
.Execute                'update currentRange to next found instance

Do While .Found

' code to insert bookmarks

Set insertRange = currentRange 'I changed this assignment from currentParagraph to currentRange
insertRange.Collapse direction:=wdCollapseEnd
' Add the new TOC field
Range:=insertRange, _
Type:=wdFieldEmpty, _
Text:=" TOC \h \o """ & HeadingNumber & "-" & TOClevel & """ \b TOCHeading" & HeadingNumber & "_" & (bookmarkNumber + 1)
bookmarkNumber = bookmarkNumber + 1

' update currentRange to next found instance
.Execute
Loop
End With

'update all newly inserted MiniTOCs
doc.Fields.Update

End Sub


You can also turn screen updating off to pick up some more performance. You will need to introduce some error handling into your code if you decide to do that though. You'll want to make sure that screen updating is always turned back on when your sub exits; even if it errors. Truthfully, I imagine that this routine should really have an error handler anyway. Here is a pretty good error handling pattern to follow.

## Other Notes:

• You really shouldn't access the document with ActiveDocument each time. It's much better to store the reference in a variable. This way, you know for a fact that the document you started working on is the one you'll continue to work on.

Dim doc as Document
Set doc = ActiveDocument

• Watch your line indentation. Ends should be at the same indentation level as the If they belong to.

• Instead of declaring HeadingNumber as a long in your sub declaration, you should consider using WdBuiltInStyle.

Sub MiniTOCFields(HeadingNumber As Long, TOCLevel As Long)
'......
' Check for occurrences of Heading X


You would have this:

Sub MiniTOCFields(headingStyle As WdBuiltInStyle, TOCLevel As Long)
'......
' Check for occurrences of Heading X