Format-cleanup document macro in Word 2010

Topic

New Reply

I have created some coding that cleans up my documents of formatting errors, e.g. converts one space after a full stop to two, converts all quote marks to straight ones, deletes extra white space at the end of paragraphs, inserts non-breaking spaces wherever there are digits (this does not currently work for post codes – I attach a word to show this), converts abbreviations to house style (eg to e.g. etc.).

The coding also converts instances of times, 5:00 p.m. to 5:00pm (or 5.00 p.m. to 5.00pm – I can’t get the macro to convert the full stop to a colon (5.00pm to 5:00pm) – also it does not work for instances of a.m. or a.m.

My coding seems to be getting longer and longer and I’m wondering if I could really simplify it. I appreciate my coding is very long winded but I would be very grateful if someone could take a look and advise me if possible. Regards, Shelley

Code:

Sub DPU_FormatCleanUpDoc()
‘ DPU_CleanUpDoc Macro
‘
‘
     Dim Fld As Field, Rng As Range, i As Long, ArrFnd
ArrFnd = Array(“[Mm]inute”, “[Hh]our”, “[Dd]ay”, “[Ww]eek”, “[Mm]onth”, “[Yy]ear”, “[Ww]orking”, “[Bb]usiness”, “Act”)
With ActiveDocument
  For Each Fld In .Fields
    If Fld.Type = wdFieldRef Then
      Set Rng = Fld.Result.Previous.Characters(1)
      If Rng.Text = ” ” Then Rng.Text = Chr(160)
    End If
  Next
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = “()”
    .Replacement.Text = “1^s2^s3″
    .Execute Replace:=wdReplaceAll
    .Text = ” () ”
    .Replacement.Text = “^s1^s”
    .Execute Replace:=wdReplaceAll
    .Text = ” ([!^s])”
    .Replacement.Text = “^s1”
    .Execute Replace:=wdReplaceAll
    .Text = “([!^s]) ”
    .Replacement.Text = “1^s”
    .Execute Replace:=wdReplaceAll
    For i = 0 To UBound(ArrFnd)
      .Text = “[^s]([0-9]{1,}^s” & ArrFnd(i) & “)”
    .Replacement.Text = ” 1″
    .Execute Replace:=wdReplaceAll
    Next
  End With
End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = “^w^p”
        .Replacement.Text = “^p”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “^p^w”
        .Replacement.Text = “^p”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “‘”
        .Replacement.Text = “‘”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
       .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “”””
        .Replacement.Text = “”””
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “:-”
        .Replacement.Text = “:”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “;-”
        .Replacement.Text = “:”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ”   ”
        .Replacement.Text = ” ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ”  ”
        .Replacement.Text = ” ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “. ”
        .Replacement.Text = “.  ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “? ”
        .Replacement.Text = “?  ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
      .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
       With Selection.Find
        .Text = “i.e”
        .Replacement.Text = “i.e.”
       .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
        Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “ie”
        .Replacement.Text = “i.e.”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “eg”
        .Replacement.Text = “e.g.”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     Selection.Find.Execute Replace:=wdReplaceAll
   With Selection.Find
        .Text = “e.g”
        .Replacement.Text = “e.g.”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “etc”
        .Replacement.Text = “etc.”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “etc..”
        .Replacement.Text = “etc.”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “..”
        .Replacement.Text = “.”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “e.g.^w”
        .Replacement.Text = “e.g. ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “i.e.^w”
        .Replacement.Text = “i.e. ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “etc.^w”
        .Replacement.Text = “etc. ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “e-mail”
        .Replacement.Text = “email”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “no.  ”
        .Replacement.Text = “no. ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
       .Text = ” p.m.”
        .Replacement.Text = “pm”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ” p.m”
        .Replacement.Text = “pm”
        .Forward = True
        .Wrap = wdFindContinue
       .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ” pm”
        .Replacement.Text = “pm”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “pm  ”
        .Replacement.Text = “pm ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “H.M. ”
        .Replacement.Text = “HM^s”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = “HM ”
        .Replacement.Text = “HM^s”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = “^s”””
        .Replacement.Text = “”””
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
         Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ” ,”
        .Replacement.Text = “,”
        .Forward = True
       .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = “? ”
        .Replacement.Text = “?  ”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ” :”
        .Replacement.Text = “:”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ” )”
        .Replacement.Text = “)”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ” ;”
        .Replacement.Text = “;”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = “^s ”
        .Replacement.Text = “^s”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = “-”
        .Replacement.Text = “-”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = “^sand^s”
        .Replacement.Text = ” and^s”
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
       Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Reply | Quote

Replies

Try:

Code:

Sub DPU_FormatCleanUpDoc()
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, i As Long, ArrFnd
ArrFnd = Array("[Mm]inute", "[Hh]our", "[Dd]ay", "[Ww]eek", "[Mm]onth", "[Yy]ear", "[Ww]orking", "[Bb]usiness", "Act")
With ActiveDocument
  For Each Fld In .Fields
    If Fld.Type = wdFieldRef Then
      Set Rng = Fld.Result.Previous.Characters(1)
      If Rng.Text = " " Then Rng.Text = Chr(160)
    End If
  Next
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "()"
    .Replacement.Text = "1^s2^s3"
    .Execute Replace:=wdReplaceAll
    .Text = " () "
    .Replacement.Text = "^s1^s"
    .Execute Replace:=wdReplaceAll
    .Text = " ([!^s])"
    .Replacement.Text = "^s1"
    .Execute Replace:=wdReplaceAll
    .Text = "([!^s]) "
    .Replacement.Text = "1^s"
    .Execute Replace:=wdReplaceAll
    For i = 0 To UBound(ArrFnd)
      .Text = "[^s]([0-9]{1,}^s" & ArrFnd(i) & ")"
      .Replacement.Text = " 1"
      .Execute Replace:=wdReplaceAll
    Next
    .MatchWildcards = False
    .Text = "^w^p"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "^p^w"
    .Execute Replace:=wdReplaceAll
    .Text = "'"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
    .Text = """"
    .Execute Replace:=wdReplaceAll
    .MatchWildcards = True
    .Text = "[^s ]([ap]).m."
    .Replacement.Text = "1m"
    .Execute Replace:=wdReplaceAll
    .Text = "[^s ]([ap]).m>"
    .Execute Replace:=wdReplaceAll
    .Text = "([:;])-"
    .Replacement.Text = "1"
    .Execute Replace:=wdReplaceAll
    .Text = "([^s ])[^s ]{1,}"
    .Execute Replace:=wdReplaceAll
    .Text = "([.?])[^s ]"
    .Replacement.Text = "1  "
    .Execute Replace:=wdReplaceAll
    .Text = "<(i.e)([!.])"
    .Replacement.Text = "1.2"
    .Execute Replace:=wdReplaceAll
    .Text = "<(e.g)([!.])"
    .Execute Replace:=wdReplaceAll
    .Text = "<(etc)([!.])"
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Replacement.Text = "i.e."
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Replacement.Text = "e.g."
    .Execute Replace:=wdReplaceAll
    .Text = "[.]{2,}"
    .Replacement.Text = "."
    .Execute Replace:=wdReplaceAll
    .Text = "e-mail"
    .Replacement.Text = "email"
    .Execute Replace:=wdReplaceAll
    .Text = "no.  "
    .Replacement.Text = "no. "
    .Execute Replace:=wdReplaceAll
    .Text = "<H.M. "
    .Replacement.Text = "HM^s"
    .Execute Replace:=wdReplaceAll
    .Text = "<HM "
    .Execute Replace:=wdReplaceAll
    .Text = "^s"""
    .Replacement.Text = """"
    .Execute Replace:=wdReplaceAll
    .Text = " ([,:;)])"
    .Replacement.Text = "1"
    .Execute Replace:=wdReplaceAll
    .Text = "-"
    .Replacement.Text = "-"
    .Execute Replace:=wdReplaceAll
    .Text = "^sand^s"
    .Replacement.Text = " and^s"
    .Execute Replace:=wdReplaceAll
  End With
End With
End Sub

Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Reply | Quote

Hi Macropod, thank you for taking the time to look at my rather bad coding. I have run your macro and most if it works ok except for a couple of things.

not converting curly quotes to straight quotes like it did before
adding a non-breaking space after the digit and before am/pm
when converting H.M. adding an extra space after HM[non-breaking space][space]Land Registry
not deleting extra full stops (e.g. the end… to the end.)

I’ve looked at the coding but can’t fathom how to change it.
Regards
Shelley

Reply | Quote

To convert curly quotes to straight quotes, insert:
.Replacement.Text = Chr(34)
after:
.Text = “”””

To enforce a non-breaking space before am/pm, change:
.Replacement.Text = “1m”
to:
.Replacement.Text = “^s1m”

To enforce a non-breaking space and an ordianry space after MH, change:
.Replacement.Text = “HM^s”
to:
.Replacement.Text = “HM^s ”

The macro already has code to delete repeated periods, and does so. Are you sure what you have isn’t an ellipsis (…) or periods interspersed with spaces (. . .)?

Commented code follows:

Code:

Sub DPU_FormatCleanUpDoc()
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, i As Long, ArrFnd
ArrFnd = Array("[Mm]inute", "[Hh]our", "[Dd]ay", "[Ww]eek", "[Mm]onth", "[Yy]ear", "[Ww]orking", "[Bb]usiness", "Act")
With ActiveDocument
  'ensure spaces after cross-references are non-breaking
  For Each Fld In .Fields
    If Fld.Type = wdFieldRef Then
      Set Rng = Fld.Result.Previous.Characters(1)
      Rng.Text = Replace(Rng.Text, " ", Chr(160))
    End If
  Next
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    'Ensure spaces withing dates are non-breaking
    .Text = "()"
    .Replacement.Text = "1^s2^s3"
    .Execute Replace:=wdReplaceAll
    'Ensure spaces before numbers are non-breaking
    .Text = " ([0-9])"
    .Replacement.Text = "^s1"
    .Execute Replace:=wdReplaceAll
    'Ensure spaces after numbers are non-breaking
    .Text = "([0-9]) "
    .Replacement.Text = "1^s"
    .Execute Replace:=wdReplaceAll
    'Ensure spaces before numbers in the array are ordinary
    For i = 0 To UBound(ArrFnd)
      .Text = "^s([0-9]{1,}^s" & ArrFnd(i) & ")"
      .Replacement.Text = " 1"
      .Execute Replace:=wdReplaceAll
    Next
    .MatchWildcards = False
    'Delete white spaces before paragraph breaks
    .Text = "^w^p"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAllFalse
    'Delete white spaces after paragraph breaks
    .Text = "^p^w"
    .Execute Replace:=wdReplaceAll
    'Replace straight single quotes with smart single quotes
    .Text = "'"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
    'Replace smart double quotes with straight double quotes
    .Text = """"
    .Replacement.Text = Chr(34)
    .Execute Replace:=wdReplaceAll
    'Delete periods in a.m./p.m.
    .MatchWildcards = True
    .Text = "[^s ]([ap]).m."
    .Replacement.Text = "^s1m"
    .Execute Replace:=wdReplaceAll
    .Text = "[^s ]([ap]).m>"
    .Execute Replace:=wdReplaceAll
    'Delete - following a : or ;
    .Text = "([:;])-"
    .Replacement.Text = "1"
    .Execute Replace:=wdReplaceAll
    'Replace all double + spaces with single spaces of the same kind as the first
    .Text = "([^s ])[^s ]{1,}"
    .Execute Replace:=wdReplaceAll
    'Ensure there are two ordinary spaces following . and ?
    .Text = "([.?])[^s ]"
    .Replacement.Text = "1  "
    .Execute Replace:=wdReplaceAll
    'Ensure i.e., e.g. & etc. are properly formatted
    .Text = "<(i.e)([!.])"
    .Replacement.Text = "1.2"
    .Execute Replace:=wdReplaceAll
    .Text = "<(e.g)([!.])"
    .Execute Replace:=wdReplaceAll
    .Text = "<(etc)([!.])"
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Replacement.Text = "i.e."
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Replacement.Text = "e.g."
    .Execute Replace:=wdReplaceAll
    .Text = "[.]{2,}"
    .Replacement.Text = "."
    .Execute Replace:=wdReplaceAll
    'Remove hyphens from e-mail
    .Text = "e-mail"
    .Replacement.Text = "email"
    .Execute Replace:=wdReplaceAll
    'Ensure 'no.' has only a single following space
    .Text = "no.  "
    .Replacement.Text = "no. "
    'Ensure H.M. & HM appear as HM followed by both a non-breaking space and an ordinary space
    .Execute Replace:=wdReplaceAll
    .Text = "<H.M. "
    .Replacement.Text = "HM^s "
    .Execute Replace:=wdReplaceAll
    .Text = "<HM "
    .Execute Replace:=wdReplaceAll
    'Delete non-breaking spaces before double-quotes
    .Text = "^s"""
    .Replacement.Text = """"
    .Execute Replace:=wdReplaceAll
    'Delete spaces before , : ; )
    .Text = " ([,:;)])"
    .Replacement.Text = "1"
    .Execute Replace:=wdReplaceAll
    'Replace hyphens. Why?
    .Text = "-"
    .Replacement.Text = "-"
    .Execute Replace:=wdReplaceAll
    'Replace non-breaking spaces with ordinary spaces before 'and' when followed by a non-breaking space
    .Text = "^sand^s"
    .Replacement.Text = " and^s"
    .Execute Replace:=wdReplaceAll
  End With
End With
End Sub

Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Reply | Quote

I suggest you put comments throughout the code, explaining what is happening at each step. Also, indent and add blank lines, to make it more readable. Doing these things will help you to quickly spot ways you can improve your code. It will also make your macro easier to modify in the future.

For what you’re trying to do, however, you might not be able to shorten it much, since you’re trying to replace many different characters with other characters.

Group "L" (Linux Mint)
with Windows 10 running in a remote session on my file server

Reply | Quote

For what you’re trying to do, however, you might not be able to shorten it much, since you’re trying to replace many different characters with other characters.

I could make the code significantly shorter than what I’ve already done, but then it would be much harder to interpret and maintain.

Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Reply | Quote

Hi Macropod, thank you so much for your help with the macro. I have updated the macro to convert smart apostrophe to straight using code = Chr(39) which has worked.

When there is a digit[space]semi-colon the macro is converting the space to a [non-breaking space]semi-colon as the coding at the beginning of the macro inserts non-breaking spaces wherever there are digits so I need to add something in maybe at the end of the coding to convert this back to no space before semi-colons.

The macro is converting H.M.[space]Land Registry to HM[non-breaking space][space][space]Land Registry. I’ve tried altering this to HM[non-breaking space]Land Registry but it isn’t working.

The macro works well converting 8:00 a.m. and 8:00 p.m. to 8:00am and 8:00pm. Is there a way for the macro to look for instances of digits before am and pm (with no full stops), e.g. 8:00 am or 8:00 pm to 8:00am and 8:00pm. I can get it to work for ‘pm’ but ‘am’ seems to change any instance of ‘I am’ to ‘Iam’.

If in the document abbreviations are already in house style – e.g. or i.e. or etc. the macro is adding two spaces after the full stop because we’ve asked the macro to do so when adding in two spaces after full stops for sentences. How can I change this.

I’ve attached a doc to test the macro and a doc where the macro has run if that helps at all.
Regards Shelley

Reply | Quote

When there is a digit[space]semi-colon the macro is converting the space to a [non-breaking space]semi-colon as the coding at the beginning of the macro inserts non-breaking spaces wherever there are digits so I need to add something in maybe at the end of the coding to convert this back to no space before semi-colons.

The macro is converting H.M.[space]Land Registry to HM[non-breaking space][space][space]Land Registry. I’ve tried altering this to HM[non-breaking space]Land Registry but it isn’t working.

The macro works well converting 8:00 a.m. and 8:00 p.m. to 8:00am and 8:00pm. Is there a way for the macro to look for instances of digits before am and pm (with no full stops), e.g. 8:00 am or 8:00 pm to 8:00am and 8:00pm. I can get it to work for ‘pm’ but ‘am’ seems to change any instance of ‘I am’ to ‘Iam’.

If in the document abbreviations are already in house style – e.g. or i.e. or etc. the macro is adding two spaces after the full stop because we’ve asked the macro to do so when adding in two spaces after full stops for sentences. How can I change this.

Sometimes, the outcome will be affected by the order in which actions are done; other times a different approach is required. Try:

Code:

Sub DPU_FormatCleanUpDoc()
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, i As Long, ArrFnd
ArrFnd = Array("[Mm]inute", "[Hh]our", "[Dd]ay", "[Ww]eek", "[Mm]onth", "[Yy]ear", "[Ww]orking", "[Bb]usiness", "Act")
With ActiveDocument
  'ensure spaces after cross-references are non-breaking
  For Each Fld In .Fields
    If Fld.Type = wdFieldRef Then
      Set Rng = Fld.Result.Previous.Characters(1)
      Rng.Text = Replace(Rng.Text, " ", Chr(160))
    End If
  Next
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    'Ensure spaces withing dates are non-breaking
    .Text = "()"
    .Replacement.Text = "1^s2^s3"
    .Execute Replace:=wdReplaceAll
    'Ensure spaces before numbers are non-breaking
    .Text = " ([0-9])"
    .Replacement.Text = "^s1"
    .Execute Replace:=wdReplaceAll
    'Ensure spaces after numbers are non-breaking
    .Text = "([0-9]) "
    .Replacement.Text = "1^s"
    .Execute Replace:=wdReplaceAll
    'Ensure spaces before numbers in the array are ordinary spaces
    For i = 0 To UBound(ArrFnd)
      .Text = "^s([0-9]{1,}^s" & ArrFnd(i) & ")"
      .Replacement.Text = " 1"
      .Execute Replace:=wdReplaceAll
    Next
    .MatchWildcards = False
    'Delete white spaces before paragraph breaks
    .Text = "^w^p"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAllFalse
    'Delete white spaces after paragraph breaks
    .Text = "^p^w"
    .Execute Replace:=wdReplaceAll
    'Replace smart single quotes with straight single quotes
    .Text = "'"
    .Replacement.Text = Chr(39)
    .Execute Replace:=wdReplaceAll
    'Replace smart double quotes with straight double quotes
    .Text = """"
    .Replacement.Text = Chr(34)
    .Execute Replace:=wdReplaceAll
    'Delete periods in a.m./p.m.
    .MatchWildcards = True
    .Text = "[^s ]([ap]).m."
    .Replacement.Text = "^s1m"
    .Execute Replace:=wdReplaceAll
    .Text = "[^s ]([ap]).m>"
    .Execute Replace:=wdReplaceAll
    'Delete spaces in # am/pm
    .Text = "([0-9])[^s ]([ap]m)"
    .Replacement.Text = "12"
    .Execute Replace:=wdReplaceAll
    'Delete - following a : or ;
    .Text = "([:;])-"
    .Replacement.Text = "1"
    .Execute Replace:=wdReplaceAll
    'Replace all double + spaces with single spaces of the same kind as the first
    .Text = "([^s ])[^s ]{1,}"
    .Execute Replace:=wdReplaceAll
    'Replace repeated . with single .
    .Text = "[.]{2,}"
    .Replacement.Text = "."
    .Execute Replace:=wdReplaceAll
    'Temporarily replace i.e. formatting
    .Text = "<i.e."
    .Replacement.Text = "i¶e¶"
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Execute Replace:=wdReplaceAll
    'Temporarily replace e.g. formatting
    .Text = "<e.g."
    .Replacement.Text = "e¶g¶"
    .Execute Replace:=wdReplaceAll
    .Text = ""
    'Temporarily replace etc. formatting
    .Execute Replace:=wdReplaceAll
    .Text = "<etc."
    .Replacement.Text = "etc¶"
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Execute Replace:=wdReplaceAll
    'Ensure H.M. & HM appear as HM followed by both a non-breaking space and an ordinary space
    .Execute Replace:=wdReplaceAll
    .Text = "<HM[^s ]{1,}"
    .Replacement.Text = "HM^s "
    .Execute Replace:=wdReplaceAll
    .Text = "<H.M.[^s ]{1,}"
    .Execute Replace:=wdReplaceAll
    'Ensure there are two ordinary spaces following . and ?
    .Text = "([.?])[^s ]"
    .Replacement.Text = "1  "
    .Execute Replace:=wdReplaceAll
    'Restore i.e., e.g. & etc. formatting
    .Text = "¶"
    .Replacement.Text = "."
    .Execute Replace:=wdReplaceAll
    'Remove hyphens from e-mail
    .Text = "e-mail"
    .Replacement.Text = "email"
    .Execute Replace:=wdReplaceAll
    'Ensure 'no.' has only a single following space
    .Text = "no.  "
    .Replacement.Text = "no. "
    'Delete non-breaking spaces before double-quotes
    .Text = "^s"""
    .Replacement.Text = """"
    .Execute Replace:=wdReplaceAll
    'Delete spaces before , : ; )
    .Text = "[^s ]([,:;)])"
    .Replacement.Text = "1"
    .Execute Replace:=wdReplaceAll
    'Replace hyphens. Why?
    .Text = "-"
    .Replacement.Text = "-"
    .Execute Replace:=wdReplaceAll
    'Replace non-breaking spaces with ordinary spaces before 'and' when followed by a non-breaking space
    .Text = "^sand^s"
    .Replacement.Text = " and^s"
    .Execute Replace:=wdReplaceAll
  End With
End With
End Sub

Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Reply | Quote

Hi Macropod, thank you so much the macro works brilliantly. Regards, Shelley

Reply | Quote