Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
  .Text = UCase(.Text)
  With .Font
    .Name = "Arial"
    .Size = 12
  End With
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
  Set Rng = .Characters.First
  Do While Rng.End < .End - 1
  Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\Line")
  With Rng
    If .Characters.Last <> vbCr Then .InsertAfter Chr(11) & Chr(11)
    .Collapse wdCollapseEnd
  End With
  Loop
  With .Find
    .Text = "^13"
    .Replacement.Text = "^p^p"
    .Execute Replace:=wdReplaceAll
    '.Text = "^11"
    '.Replacement.Text = "^p"
    '.Execute Replace:=wdReplaceAll
  End With
  While .Characters.Last.Previous = vbCr
    .Characters.Last.Previous.Delete
  Wend
End With
Application.ScreenUpdating = True
End Sub