Sub FormatManualNumbering()
'In active doc, format multi-level manual numbering.

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
'Insert a para sign at the doc's start to include the doc's 1st para in work:
    rng.Characters.First.InsertBefore Chr(13)
     rngEnd = rng.End
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
'Insert a tab before any 1st letter in a para:
        .text = "(^13[!^13]@)([A-Za-z])"
        .Replacement.text = "\1^t\2"
        .Execute Replace:=wdReplaceAll
'Replace two tabs with one tab:
        .text = "^t^t"
        .Replacement.text = "^t"
        .Execute Replace:=wdReplaceAll
'Delete tabs between letters, which have been inserted earlier:
        .text = "([A-Za-z])^t([A-Za-z])"
        .Replacement.text = "\1\2"
        .Execute Replace:=wdReplaceAll
    End With
'Running the next Find-Replace causes run-time error 5623
'(The Replace With text contains a group number which is out of range)
'which may occur because the parameters of Find-Replace may be kept in the next use of Find-Replace.
'Resetting rng is one of the ways to correct the error:
    Set rng = ActiveDocument.range
    Do
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchWildcards = True
'Find a str between a tab & the nearest previous para sign, i.e.
'a str between a para sign & a tab, excluding other paras in-between:
            .text = "^13[!^13]@^t"
'Within the found str replace all series of commas, colons, semicolons & spaces with a period:
            If .Execute And rng.End <= rngEnd Then
                 .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
'Delete all periods immediately before a tab:
            While rng.Characters.Last.Previous = "."
                rng.Characters.Last.Previous.Delete
            Wend
            rng.Collapse wdCollapseEnd
        End With
    Loop
'Reset rng (see the comment above):
    Set rng = ActiveDocument.range
    With rng.Find
         .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
'Insert periods after lone 1st-level numberings:
        .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll
'Delete extra periods in the doc:
        .text = "[.]{2;}"
        .Replacement.text = "."
        .Execute Replace:=wdReplaceAll
    End With
'Delete the doc's starting para sign inserted previously:
    ActiveDocument.range.Characters.First.Delete
 Application.ScreenUpdating = True
Set rng = Nothing
End Sub