macro to automatically change things

[hoekman]

The yellow is the failure message


Sub ReformatDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, l As Long, Str As String
Dim RngDoc As Range, RngTmp As Range, RngVrs As Range, RngCmt As Range
Dim bQuot As Boolean, SBar As Boolean, oPara As Paragraph
bQuot = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = False
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set RngDoc = ActiveDocument.Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindContinue
.Format = True
.Font.Italic = True
.MatchWildcards = True
.Text = "^13([!0-9]*^13)"
.Replacement.Text = " ^l\1"
.Execute Replace:=wdReplaceAll


.Format = False
.Text = "[ ]@^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "[ ]{2;}"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
.Text = "\[[0-9]@\]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute

I attached the document