November 2025

This is another attempt to use Claude to write a macro that creates a reverse outline of a document. It uses the first sentence of each paragraph to create headings for each paragraph, then creates a table of contents based on those headings, as well as any the writer has previously created.

Sub InsertFirstSentencesAndTOC()
Dim doc As Document
Dim para As Paragraph
Dim firstSentence As String
Dim sentenceEnd As Long
Dim paraText As String
Dim sourceRange As Range
Dim newPara As Paragraph
Dim userStyle As String
Dim i As Long
Dim paraCount As Long
Dim tocRange As Range

' Get the active document
Set doc = ActiveDocument

' Ask user for the style to apply
userStyle = inputBox("Enter the Microsoft Word style name to apply to the first sentence headings:" & vbCrLf & vbCrLf & _
                     "Examples:" & vbCrLf & _
                     "• Heading 1" & vbCrLf & _
                     "• Heading 2" & vbCrLf & _
                     "• Heading 3" & vbCrLf & _
                     "• Subtitle" & vbCrLf & _
                     "• Title" & vbCrLf & _
                     "• Emphasis", _
                     "Select Heading Style", _
                     "Heading 2")

' Check if user cancelled
If userStyle = "" Then
    MsgBox "Operation cancelled.", vbInformation
    Exit Sub
End If

' Check if the style exists in the document
On Error Resume Next
Dim testStyle As Style
Set testStyle = doc.Styles(userStyle)
If Err.Number <> 0 Then
    MsgBox "The style '" & userStyle & "' does not exist in this document." & vbCrLf & vbCrLf & _
           "Please check the style name and try again.", vbExclamation, "Style Not Found"
    Exit Sub
End If
On Error GoTo 0

' Get initial paragraph count
paraCount = doc.Paragraphs.count

' Loop through paragraphs in reverse order to avoid issues with inserting new paragraphs
For i = paraCount To 1 Step -1
    Set para = doc.Paragraphs(i)

    ' Get paragraph text and trim whitespace
    paraText = Trim(para.Range.text)

    ' Skip empty paragraphs
    If Len(paraText) > 1 Then
        ' Find the first sentence by looking for sentence-ending punctuation
        sentenceEnd = 0

        ' Look for period, exclamation mark, or question mark
        Dim j As Long
        For j = 1 To Len(paraText)
            If Mid(paraText, j, 1) = "." Or Mid(paraText, j, 1) = "!" Or Mid(paraText, j, 1) = "?" Then
                ' Check if it's not an abbreviation or decimal
                If j < Len(paraText) Then
                    Dim nextPos As Long
                    nextPos = j + 1

                    ' Skip over footnote numbers (digits) that might follow the punctuation
                    While nextPos <= Len(paraText) And IsNumeric(Mid(paraText, nextPos, 1))
                        nextPos = nextPos + 1
                    Wend

                    ' Now check if followed by space and capital letter
                    If nextPos <= Len(paraText) And Mid(paraText, nextPos, 1) = " " Then
                        If nextPos + 1 <= Len(paraText) Then
                            If Asc(Mid(paraText, nextPos + 1, 1)) >= 65 And Asc(Mid(paraText, nextPos + 1, 1)) <= 90 Then
                                sentenceEnd = nextPos - 1 ' Include footnote numbers in the sentence
                                Exit For
                            End If
                        End If
                    ElseIf nextPos > Len(paraText) Then
                        ' If we've reached end of paragraph after footnote numbers
                        sentenceEnd = j
                        ' Include any footnote numbers that were at the end
                        While sentenceEnd < Len(paraText) And IsNumeric(Mid(paraText, sentenceEnd + 1, 1))
                            sentenceEnd = sentenceEnd + 1
                        Wend
                        Exit For
                    End If
                Else
                    ' If it's at the end of paragraph, it's end of sentence
                    sentenceEnd = j
                    Exit For
                End If
            End If
        Next j

        ' Extract the first sentence
        If sentenceEnd = 0 Then
            ' No sentence ending found, take the whole paragraph (minus paragraph mark)
            sentenceEnd = Len(paraText) - 1
        End If

        ' Create a range for the first sentence in the source document
        Set sourceRange = para.Range.Duplicate
        sourceRange.End = para.Range.Start + sentenceEnd

        ' Add the sentence before the current paragraph if not empty
        If Trim(sourceRange.text) <> "" Then
            ' Create a new paragraph before the current one
            Dim insertRange As Range
            Set insertRange = para.Range
            insertRange.Collapse Direction:=wdCollapseStart

            ' Copy the first sentence
            sourceRange.Copy
            insertRange.Paste

            ' Add paragraph break after the pasted content
            insertRange.Collapse Direction:=wdCollapseEnd
            insertRange.InsertParagraphAfter

            ' Get the newly created paragraph
            Set newPara = insertRange.Paragraphs(1)

            ' Apply the user-specified style
            newPara.Style = userStyle
        End If
    End If
Next i

' Now create the Table of Contents at the beginning of the document
' Move cursor to the start of the document
Set tocRange = doc.Range(0, 0)

' Insert a title for the TOC
tocRange.text = "Table of Contents" & vbCrLf & vbCrLf
tocRange.Paragraphs(1).Style = "Heading 1"

' Move to the end of the TOC title (after the second paragraph break)
Set tocRange = doc.Range(tocRange.End, tocRange.End)

' Insert the Table of Contents
' This will include all heading levels found in the document
On Error Resume Next
doc.TablesOfContents.Add _
    Range:=tocRange, _
    UseHeadingStyles:=True, _
    UpperHeadingLevel:=1, _
    LowerHeadingLevel:=9, _
    UseFields:=True, _
    UseHyperlinks:=True, _
    HidePageNumbersInWeb:=False

If Err.Number <> 0 Then
    MsgBox "Table of Contents created, but there may have been an issue. " & _
           "You can update it by right-clicking and selecting 'Update Field'.", _
           vbInformation, "TOC Created"
End If
On Error GoTo 0

' Add a page break after the TOC
tocRange.Collapse Direction:=wdCollapseEnd
tocRange.InsertBreak Type:=wdPageBreak

' Move cursor to the start of the document
doc.Range(0, 0).Select

MsgBox "First sentences inserted as headings with style '" & userStyle & "' and Table of Contents created!", _
       vbInformation, "Macro Complete"

End Sub