Unfortunately, the numbering of my Word headings often goes wrong. It unexpectedly restarts from the beginning (1, 1.1, 1.1.1), and choosing to continue numbering from the quick menu doesn’t help. This usually occurs when several parties with different Word versions modify the same file and forward it to each other. This is, of course, not good practice, but it’s unavoidable at times.

The last time we worked with a client on a document, the same mistake happened again. In this situation, that mistake would have been unacceptable. I decided to solve this problem once and for all.

As an aside, many years ago, I migrated a document to LaTeX in a similar situation. That didn’t end well because, although the client was happy with the result, he wanted to make regular changes that he couldn’t do himself.

So now I decided to solve this problem once and for all, within Word. I wrote the code using AI, but as it performed surprisingly poorly (perhaps Visual Basic is under-represented on the net compared to more popular programming languages?), I had to go step by step, and gradually incorporated the solution to a problem into the solution.

Sub ListHeadingParagraphsToNewDoc_Final()
    Dim newDoc As Document
    Dim originalDoc As Document
    
    Dim para As Paragraph
    Dim out As String
    Dim msg As String
    
    Set originalDoc = ActiveDocument
    Set newDoc = Documents.Add

    originalDoc.Activate
    For Each para In ActiveDocument.Paragraphs
        If para.Style Like "Heading*" Or para.Style Like "*msor*" Then
            msg = ""
            With para.Range.ListFormat
                If .ListType <> wdListNoNumbering Then
                    levelIndex = .ListLevelNumber
                    msg = msg & "Levelindex: " & levelIndex & vbCrLf
                    msg = msg & "Visible numbering (ListString): " & .ListString & vbCrLf
        
                    If Not .listTemplate Is Nothing Then
                        Set listTemplate = .listTemplate
                        If levelIndex >= 1 And levelIndex <= listTemplate.ListLevels.Count Then
                            Set listLevel = listTemplate.ListLevels(levelIndex)
                            msg = msg & "NumberFormat: " & listLevel.NumberFormat & vbCrLf
                            msg = msg & "StartAt: " & listLevel.StartAt & vbCrLf
                            msg = msg & "LinkedStyle: " & listLevel.LinkedStyle & vbCrLf
                            msg = msg & "NumberStyle: " & listLevel.NumberStyle & vbCrLf
                            msg = msg & "NumberPosition: " & listLevel.NumberPosition & vbCrLf
                            msg = msg & "TextPosition: " & listLevel.TextPosition & vbCrLf
                            listLevel.LinkedStyle = para.Style
                        Else
                            msg = msg & "[ListLevel not accessible]" & vbCrLf
                        End If
                    Else
                        msg = msg & "[There is no ListTemplate]" & vbCrLf
                    End If
                Else
                    msg = msg & "[There is no numbering]" & vbCrLf
                End If
            End With
            
            out = "Style: " & para.Style & vbCrLf & _
                    msg & _
                   "Text: " & Replace(para.Range.Text, vbCr, "") & vbCrLf
            Debug.Print out
            newDoc.Content.InsertAfter out & vbCrLf
            
        End If
    Next para

    newDoc.Activate"

    'MsgBox "Ready!", vbInformation
End Sub

The root of the problem is that the heading style loses the “linkedStyle” property somehow, so the numbering is not applied consistently. I’m not sure why this is happening. The user interface seems to apply the styles and headings correctly. It may be caused by editing the file with a mix of English and Hungarian Word, or perhaps the versions are different.

The solution lies in the line “listLevel.LinkedStyle = para.Style,” where we fix the missing style link. The macro logs to a separate document for debugging purposes.