Option Explicit Private oRngNum As Range Sub FormatManualNumbering() Dim oRng As Range Dim oPar As Paragraph     Application.ScreenUpdating = False     Set oRng = ActiveDocument.Range     oRng.InsertBefore vbCr     With oRng.Find       .ClearFormatting       .Replacement.ClearFormatting       .Forward = True       .Wrap = wdFindStop       .Format = False       .MatchWildcards = False       'Remove spaces starting paras:       .Text = "^p^w"       .Replacement.Text = "^p"       .Execute Replace:=wdReplaceAll     End With     oRng.Characters(1).Delete     For Each oPar In oRng.Paragraphs       If IsNumeric(oPar.Range.Characters(1)) Then         Set oRngNum = oPar.Range         oRngNum.Collapse wdCollapseStart         Do Until oRngNum.Characters.Last.Next Like "[A-Za-z]"           oRngNum.MoveEnd wdCharacter, 1         Loop         ProcessNum       End If     Next    Application.ScreenUpdating = True lbl_Exit:   Exit Sub End Sub Sub ProcessNum() Dim oRng As Range Dim lngIndex As Long Dim bAllNums As Boolean   bAllNums = True   Set oRng = oRngNum.Duplicate   oRng.Collapse wdCollapseEnd   Do Until IsNumeric(oRng.Characters.First.Previous)     oRng.MoveStart wdCharacter, -1   Loop   oRng.Text = "." & vbTab   oRngNum.End = oRng.Start   For lngIndex = 1 To oRngNum.Characters.Count     If Not IsNumeric(oRngNum.Characters(lngIndex)) Then       If oRngNum.Characters(lngIndex) = " " And oRngNum.Characters(lngIndex).Previous = "." Then         oRngNum.Characters(lngIndex).Delete         lngIndex = lngIndex + 1       Else         oRngNum.Characters(lngIndex) = "."         bAllNums = False       End If     End If   Next   If Not bAllNums Then oRngNum.Characters.Last.Next.Delete lbl_Exit:   Exit Sub End Sub