Macro for Word | Breadcrumbs | Project: Microcredentialing Toolkit

Been working with ChatGPT to format a 200-page toolkit.  Slowly we will get to Kingston.  It won't format the doc for me as usual, but it suggests options.  It also will format in chunks.  Chat GPT suggested I use breadcrumbs to format a Word doc that will be a PDF.  I was inserted breadcrumbs manually using cross referencing function as recommended, but it was laborious especially in such a long doc. I realized adding dozens of continuous breaks along with insert header cross ref, multiples per header level, was a significant amount of my time. After a few rounds I was able to get Chat GPT to provide something useful.

Keywords: #chatgpt #macro #word #toolkit #microcredentialing

 Sub InsertBreadcrumbHeader()

    Dim sec As Section

    Dim hdr As HeaderFooter

    Dim rng As Range

    Dim para As Paragraph

    Dim breadcrumb As String

    Dim currentPage As Long

    Dim paraPage As Long

    Dim headingStyles As Variant

    Dim i As Integer

    ' Array of heading styles to check (H1 to H6)

    headingStyles = Array("Heading 1", "Heading 2", "Heading 3", "Heading 4", "Heading 5", "Heading 6")

    ' Loop through all sections in the document

    For Each sec In ActiveDocument.Sections

        ' Work with the primary header

        Set hdr = sec.Headers(wdHeaderFooterPrimary)

        hdr.Range.Text = "" ' Clear the header

        ' Get the current page of the header

        currentPage = hdr.Range.Information(wdActiveEndPageNumber)

        breadcrumb = ""

        ' Loop through all paragraphs in the document

        For Each para In ActiveDocument.Paragraphs

            ' Check if the paragraph is a heading style

            For i = LBound(headingStyles) To UBound(headingStyles)

                If para.Style = headingStyles(i) Then

                    ' Check if the heading is on the same page as the header

                    paraPage = para.Range.Information(wdActiveEndPageNumber)

                    If paraPage = currentPage Then

                        breadcrumb = breadcrumb & para.Range.Text & " > "

                    End If

                End If

            Next i

        Next para

        ' Remove the trailing " > " from the breadcrumb

        If Len(breadcrumb) > 3 Then

            breadcrumb = Left(breadcrumb, Len(breadcrumb) - 3)

        End If

        ' Set the breadcrumb in the header

        If breadcrumb = "" Then

            hdr.Range.Text = "Breadcrumb: No headings on this page."

        Else

            hdr.Range.Text = "Breadcrumb: " & breadcrumb

        End If

    Next sec

    MsgBox "Breadcrumb headers added successfully."

End Sub