Numbered Outline Continuation Headings

gmayor · #1 08-19-2017, 04:39 AM

From what I understand from your dilemma, you wish to insert an incremented bookmark name each time the macro is run. You can do that with a couple of additional functions e.g. as shown below. I have not tested the concept of the macro itself, only the bookmark issue. The first time the macro is run, the bookmark added is called ABC, the next time ABC1 then ABC2 etc.

You can test the process with

Code:

Sub Macro1()
Dim strName As String
    strName = "ABC"
    strName = BookmarkUnique(strName, ActiveDocument)
            ActiveDocument.Bookmarks.Add Name:=strName, Range:=Selection.Range
End Sub

Code:

Option Explicit

Sub ProofOfConcept()
'macro by Andrew Lockton
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Aug 2017
Dim aRng As Range, iLev As Integer
Dim strName As String
    strName = "ABC"
    Set aRng = ActiveDocument.Bookmarks("\page").Range
    aRng.InsertParagraphBefore
    With aRng.Paragraphs(1)
        .Style = "Normal"
        .OutlinePromote
        iLev = .OutlineLevel
        If iLev > 3 Then
            .Style = "Normal"
            aRng.Collapse direction:=wdCollapseStart
            aRng.Select
            Selection.GoTo What:=wdGoToHeading, which:=wdGoToPrevious, Count:=1
            While Selection.Paragraphs(1).OutlineLevel <> iLev - 1
                Selection.GoTo What:=wdGoToHeading, which:=wdGoToPrevious, Count:=1
            Wend
            strName = BookmarkUnique(strName, ActiveDocument)
            ActiveDocument.Bookmarks.Add Name:=strName, Range:=Selection.Range
            aRng.InsertAfter " continued"
            aRng.Collapse direction:=wdCollapseStart
            ActiveDocument.Fields.Add Range:=aRng, Text:="Ref " & strName & " \w \h"
            aRng.Select
        Else
            aRng.Paragraphs(1).Range.Delete
        End If
    End With
End Sub

Private Function BookmarkUnique(strBookmark As String, oDoc As Document) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Aug 2017
Dim lngB As Long: lngB = 1
Dim lngName As Long
    lngName = Len(strBookmark)
    Do While BMExists(strBookmark, oDoc) = True
        strBookmark = Left(strBookmark, lngName) & lngB
        lngB = lngB + 1
    Loop
    'Reassemble the filename
    BookmarkUnique = strBookmark
lbl_Exit:
    Exit Function
End Function

Private Function BMExists(strbmName As String, oDoc As Document) As Boolean
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Aug 2017
Dim oBm As Bookmark
    For Each oBm In oDoc.Bookmarks
        If oBm.Name = strbmName Then
            BMExists = True
            Exit For
        End If
    Next oBm
lbl_Exit:
    Exit Function
    Set oBm = Nothing
End Function

rdross51 · #2 08-19-2017, 06:06 AM

Failed at " strName = BookmarkUnique(strName, ActiveDocument)"
Received compile error "sub or function not defined" with BookmarkUnique highligted

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Capturing numbered headings	jbvalen	Word VBA	5	05-04-2017 05:03 PM
Word Mixing Numbered Headings with Numbered List	Tess0	Word	11	07-15-2014 05:25 AM
Headings and Number Outline Problem (MS Office 2008)	triodia	Word	2	05-07-2012 02:03 AM
numbered headings	Caroline	Word	5	03-14-2011 09:09 AM
XML marking of Auto-numbered Headings	crose	Word	0	12-17-2009 09:55 PM