Insert Text in MS Word Multilevel List Headings Using VBA

Question

I requested help from the forum about 6 months ago but my issue remains only partly resolved. I'm hoping someone may help me recognize where my mistake is taking place in the code I have created.

My issue is that I want to use VBA to insert a very brief amount of standardized text before the English-language string in my multilevel list headings. These headings exist as Styles within my ~600 page document.

For instance, I have: 1.1.1 The Quick Brown Fox.

What I want is: 1.1.1 (XXxx) The Quick Brown Fox.

I created this macro which I then customized for each of the 6 heading levels in my document.

Public Sub InsertFOUOH1()
'Inserts U//FOUO before all first order Headings)
'Macro works on whole document
    Dim doc As Document
    Dim para As Paragraph

    Const MyText = "(U//FOUO) "
    Application.ScreenUpdating = False
    Set doc = ActiveDocument

    For Each para In doc.Paragraphs
        If para.Style = doc.Styles(wdStyleHeading1) Then
        para.Range.InsertBefore (MyText)
End If
Next para 
End Sub

This code is flawed/broken but I cannot find a solution. This works on Heading Levels 1-3. It fails on Heading Levels 4-6. The document is long and my assumption is that the sheer quantity of level 4 headings and greater causes the flawed code to fail. The code simply never completes at these heading levels.

This seems to be the part of the code that is incorrect:

For Each para In doc.Paragraphs
If para.Style = doc.Styles(wdStyleHeading1) Then
para.Range.InsertBefore (MyText)

I've tried dozens of variations on my macro and they all seem to fail at this point. In debugging, the debugger simply jumps right over the "If / Then" lines. They never get highlighted in yellow when debugging.

My understanding is that you can't programmatically select a paragraph in VBA. My heading levels are paragraphs to Word. So, my line "para.Range.InsertBefore (Mytext)" may not make any sense to the code. I tried creating a Range to make the macro work (Ranges have a 'Selection' property) but I'm doing something wrong.

I would certainly appreciate any advice about correcting my code.

Answer 1

Used the following script as a test:

Public Sub InsertFOUOH1()
'Inserts U//FOUO before all first order Headings)
'Macro works on whole document
    Dim doc As Document
    Dim para As Paragraph

    Const MyText = "(U//FOUO) "
    Application.ScreenUpdating = False
    Set doc = ActiveDocument

    For Each para In doc.Paragraphs
        If para.Style = doc.Styles(wdStyleHeading1) Then para.Range.InsertBefore ("Level 1")
        If para.Style = doc.Styles(wdStyleHeading2) Then para.Range.InsertBefore ("Level 2")
        If para.Style = doc.Styles(wdStyleHeading3) Then para.Range.InsertBefore ("Level 3")
        If para.Style = doc.Styles(wdStyleHeading4) Then para.Range.InsertBefore ("Level 4")
        If para.Style = doc.Styles(wdStyleHeading5) Then para.Range.InsertBefore ("Level 5")
        If para.Style = doc.Styles(wdStyleHeading6) Then para.Range.InsertBefore ("Level 6")
        If para.Style = doc.Styles(wdStyleHeading7) Then para.Range.InsertBefore ("Level 7")
        If para.Style = doc.Styles(wdStyleHeading8) Then para.Range.InsertBefore ("Level 8")
        If para.Style = doc.Styles(wdStyleHeading9) Then para.Range.InsertBefore ("Level 9")
    Next para
End Sub

The First time I tried it only worked to wdStyleHeading7 and I saw this was due to my Heading Styles only going up to Level 7, even though there was a 1.1.1.1.1.1.1.1 (8th Level) and a 9th level in my Document.

I then added the 8th and 9th Level Style to my Styles by selecting the text and using the Update heading to Match Selection . Once the 8th and 9th Heading Styles were added it then added the Text before the Heading Text.

Edit:

I tested it now with the para.Range.InsertBefore (MyText) and it worked fine too, due it ist simply adding the text