Create a numbered list using SEQuence fields

Article contributed by Dave Rado, based on an article by Bill Coan Bill Coan,
with thanks also to Doug Robbins

Sub CreateNumberedList()

'to apply/re-apply numbering to a range of paragraphs
'using ranges is faster than using selections, and reduces flicker

Application.ScreenUpdating = False

Dim MyRange As Range, DummyRange As Range, _
SelectedRange As Range, Counter As Long

Set SelectedRange = Selection.Range

For Counter = 1 To SelectedRange.Paragraphs.Count

    Set MyRange = SelectedRange.Paragraphs(Counter).Range

     'check para contains some text, if not, skips this para
    If Len(MyRange.Text) = 1 Then
        GoTo MissOut
    End If

     'Deletes existing seq field if present

    Set MyRange = SelectedRange.Paragraphs(Counter).Range

    If MyRange.Characters(1).Fields.Count > 0 Then
        If MyRange.Fields(1).Type = wdFieldSequence Then
            MyRange.Fields(1).Delete
            'deletes the dot and tab as well
        
   MyRange.End = MyRange.Characters(2).End
            MyRange.Delete
        End If
    End If

    'insert new sequence field

    MyRange.Collapse

    'first create a dummy range object and move it to the right one,
    'so that it will end up being located AFTER the field you're adding.
    'This is necessary because when you add a field to a range,
    'the range (unlike selection) ends up at the start of the field!!!
    'this is one of the unfortunate "features" of ranges

    Set DummyRange = MyRange.Duplicate
    DummyRange.Move unit:=wdCharacter, Count:=1

    MyRange.Fields.Add Range:=MyRange, _
            Type:=wdFieldEmpty, Text:="SEQ numberedlist\r" & Counter, _
            PreserveFormatting:=True
    Set MyRange = DummyRange.Duplicate
    MyRange.Move unit:=wdCharacter, Count:=-1

    'Set paragraph indents as desired for list

    With MyRange.ParagraphFormat
        .LeftIndent = CentimetersToPoints(1.27)
        .FirstLineIndent = CentimetersToPoints(-1.27)
    End With

    MyRange.InsertAfter "." & vbTab

MissOut:

Next Counter

SelectedRange.Select
Application.ScreenUpdating = True

End Sub