Private oRngNum As Range
Sub DPU_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
      'Remove empty paras:
        .MatchWildcards = True
        .text = "^13{2,}"
        .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
  Set oRng = ActiveDocument.Range
  With oRng.Find
  .MatchWildcards = True
  .text = "([0-9]).."
  .Replacement.text = "\1."
  .Execute Replace:=wdReplaceAll
  End With
   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
      oRngNum.Characters(lngIndex) = "."
      bAllNums = False
    End If
  Next
  If Not bAllNums Then oRngNum.Characters.Last.Next.Delete
lbl_Exit:
  Exit Sub
End Sub