TOC for CDL (doubled page numbers)

TOCforCDL.bas

Sub CreateTOCforCDL()

'Add page breaks to make all chapter titles start on an odd page number
Dim rng As Range
Dim pgNum As Integer
Set rng = ActiveDocument.Range
With rng.Find
    .style = ActiveDocument.Styles("Heading 1")
    .Forward = True
    .Wrap = wdFindStop
    
    Do While .Execute
        pgNum = rng.Information(wdActiveEndPageNumber)
        If pgNum Mod 2 = 0 Then
            rng.Collapse Direction:=wdCollapseStart
            rng.InsertBreak Type:=wdPageBreak
        End If
    Loop
End With

' Create a dictionary to store the Heading 2 text and page numbers
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

'----------CREATE A STYLE FOR THE TOC-------

'https://narkive.com/EWve4CSW:2.570.423
Dim findStyle As style, customStyle As style
Dim bFound As Boolean
Dim strcustomStyle As String

'Check for the style
strcustomStyle = "SGC custom TOC"
For Each findStyle In ActiveDocument.Styles
  If LCase(findStyle.NameLocal) = LCase(strcustomStyle) Then
  bFound = True
  Set customStyle = ActiveDocument.Styles(strcustomStyle)
Exit For
End If
Next findStyle

'If the style doesn't exist, create it
If Not bFound Then
Set customStyle = ActiveDocument.Styles.Add(Name:=strcustomStyle, _
Type:=wdStyleTypeParagraphOnly)
customStyle.BaseStyle = "Normal"
With customStyle
    .NoSpaceBetweenParagraphsOfSameStyle = True
    .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
    .ParagraphFormat.LineSpacing = 14
    .ParagraphFormat.TabStops.Add Position:=InchesToPoints(3.8), Alignment:=wdAlignTabLeft
    .ParagraphFormat.TabStops.Add Position:=InchesToPoints(5), Alignment:=wdAlignTabLeft
End With
End If
'--------------------------------------------

' Loop through each paragraph in the document
Dim para As Paragraph
For Each para In ActiveDocument.Paragraphs
    ' If the style is "Heading 2", add the text and page number to the dictionary
    If para.Range.style = "Heading 2" Then
        Dim text As String
        
        'Remove the linebreak
        text = Replace(para.Range.text, Chr(13), "")
        'Trim trailing space
        text = RTrim(text)
        
        ' Check if the heading already exists in the dictionary
        If dict.Exists(text) Then
            ' If it does, append the new page number to the existing page numbers
            dict(text) = dict(text) & vbTab & para.Range.Information(wdActiveEndAdjustedPageNumber)
        Else
            ' If it doesn't, add it to the dictionary with the page number
            dict.Add text, para.Range.Information(wdActiveEndAdjustedPageNumber)
        End If
    End If
Next para

'Page break at the end before we add the TOC
Set endRange = ActiveDocument.Content
endRange.Collapse Direction:=wdCollapseEnd
With endRange
  .InsertBreak Type:=wdPageBreak
End With

' Loop through each item in the dictionary and add it to the new document
Dim key As Variant
For Each key In dict.Keys
    
    Dim newRange As Range
    Set newRange = ActiveDocument.Content
    newRange.Collapse Direction:=wdCollapseEnd
    
    'Insert the TOC contents from the dictionary
    newRange.InsertAfter key & vbTab & dict(key) & vbCrLf
    
    'Style it
    newRange.style = customStyle
Next key

Selection.EndKey Unit:=wdStory
MsgBox "Created a custom TOC at the END of this document!"

End Sub