Results 1 to 9 of 9
  1. #1
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts

    Format-cleanup document macro in Word 2010

    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 = "(<[0-9]{1,2}) ([JFMASOND][anuryebchpilgstmov]{2,8}) ([0-9]{4}>)"
        .Replacement.Text = "\1^s\2^s\3"
        .Execute Replace:=wdReplaceAll
        .Text = " (<[0-9]{1,}>) "
        .Replacement.Text = "^s\1^s"
        .Execute Replace:=wdReplaceAll
        .Text = " (<[0-9]{1,}>[!^s])"
        .Replacement.Text = "^s\1"
        .Execute Replace:=wdReplaceAll
        .Text = "([!^s]<[0-9]{1,}>) "
        .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
    Attached Files Attached Files

  2. #2
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    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 = "(<[0-9]{1,2}) ([JFMASOND][anuryebchpilgstmov]{2,8}) ([0-9]{4}>)"
        .Replacement.Text = "\1^s\2^s\3"
        .Execute Replace:=wdReplaceAll
        .Text = " (<[0-9]{1,}>) "
        .Replacement.Text = "^s\1^s"
        .Execute Replace:=wdReplaceAll
        .Text = " (<[0-9]{1,}>[!^s])"
        .Replacement.Text = "^s\1"
        .Execute Replace:=wdReplaceAll
        .Text = "([!^s]<[0-9]{1,}>) "
        .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 = "<ie>"
        .Replacement.Text = "i.e."
        .Execute Replace:=wdReplaceAll
        .Text = "<eg>"
        .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
    [MS MVP - Word]

  3. The Following User Says Thank You to macropod For This Useful Post:

    Lady-Laughsalot (2016-03-18)

  4. #3
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    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

  5. #4
    WS Lounge VIP mrjimphelps's Avatar
    Join Date
    Dec 2009
    Location
    USA
    Posts
    3,396
    Thanks
    445
    Thanked 404 Times in 376 Posts
    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.

  6. #5
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    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 = "^s\1m"

    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 = "(<[0-9]{1,2})[^s ]([JFMASOND][anuryebchpilgstmov]{2,8})[^s ]([0-9]{4}>)"
        .Replacement.Text = "\1^s\2^s\3"
        .Execute Replace:=wdReplaceAll
        'Ensure spaces before numbers are non-breaking
        .Text = " ([0-9])"
        .Replacement.Text = "^s\1"
        .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 = "^s\1m"
        .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 = "<ie>"
        .Replacement.Text = "i.e."
        .Execute Replace:=wdReplaceAll
        .Text = "<eg>"
        .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
    Last edited by macropod; 2016-03-18 at 20:18. Reason: Added commented code
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  7. #6
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Quote Originally Posted by mrjimphelps View Post
    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
    [MS MVP - Word]

  8. #7
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts

    Format-cleanup macro for Word 2010

    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
    Attached Files Attached Files

  9. #8
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Quote Originally Posted by Lady-Laughsalot View Post
    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 = "(<[0-9]{1,2})[^s ]([JFMASOND][anuryebchpilgstmov]{2,8})[^s ]([0-9]{4}>)"
        .Replacement.Text = "\1^s\2^s\3"
        .Execute Replace:=wdReplaceAll
        'Ensure spaces before numbers are non-breaking
        .Text = " ([0-9])"
        .Replacement.Text = "^s\1"
        .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 = "^s\1m"
        .Execute Replace:=wdReplaceAll
        .Text = "[^s ]([ap]).m>"
        .Execute Replace:=wdReplaceAll
        'Delete spaces in # am/pm
        .Text = "([0-9])[^s ]([ap]m)"
        .Replacement.Text = "\1\2"
        .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 = "ie"
        .Execute Replace:=wdReplaceAll
        .Text = "<ie>"
        .Execute Replace:=wdReplaceAll
        'Temporarily replace e.g. formatting
        .Text = "<e.g."
        .Replacement.Text = "eg"
        .Execute Replace:=wdReplaceAll
        .Text = "<eg>"
        'Temporarily replace etc. formatting
        .Execute Replace:=wdReplaceAll
        .Text = "<etc."
        .Replacement.Text = "etc"
        .Execute Replace:=wdReplaceAll
        .Text = "<etc>"
        .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
    [MS MVP - Word]

  10. The Following User Says Thank You to macropod For This Useful Post:

    Lady-Laughsalot (2016-03-20)

  11. #9
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    Hi Macropod, thank you so much the macro works brilliantly. Regards, Shelley

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •