Microsoft Office Forums - View Single Post - Replace each heading with a unique numeric value

macropod · 05-05-2013, 04:16 PM

You can do this with a fairly simple macro:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim Prgrph As Paragraph, i As Long, Rng As Range
For Each Prgrph In ActiveDocument.Paragraphs
  If Prgrph.Style Like "Heading #" Then
    i = i + 1
    Set Rng = Prgrph.Range
    Rng.End = Rng.End - 1
    Rng.Text = 10000 + i
  End If
Next
Application.ScreenUpdating = True
End Sub