Sub FormatManualNumbering()

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
    rngEnd = rng.End
    rng.Characters.First.InsertBefore Chr(13)
    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:
            .text = "^13[!^13]@^t"
            If .Execute And rng.End <= rngEnd Then
                .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
'Delete a period before a tab:
            If rng.Characters.Last.Previous = "." Then
                 rng.Characters.Last.Previous.Delete
            End If
            rng.Collapse wdCollapseEnd
        End With
    Loop
'Insert periods after lone 1st-level numberings:
    Set rng = ActiveDocument.range
     With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll
    End With
ActiveDocument.range.Characters.First.Delete
Application.ScreenUpdating = True
Set rng = Nothing
 End Sub