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

    Help to shorten highlight macro in Word 2010

    HI, is anyone able to help me make the code below smaller and cleaner as in its currently state it is quite lengthy - this code is just an extract from the whole highlight code. Many thanks. Shelley

    Code:
      'highlight turquoise non-bold straight quotes
      Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = False
            Do While .Execute(FindText:=Chr(34))
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise bold apostrophes
         Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=Chr(44))
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise left bracket when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:="(")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise right bracket when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=")")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
         'highlight turquoise a colon when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=":")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
             'highlight turquoise a semi-colon when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=";")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
    This is the whole code

    Code:
    Sub DPU_HouseStyleHighlight()
     'highlights body of doc and footnotes with following commands'
    Dim StrFnd As String, i As Long
      Dim aRng As Range
      Application.ScreenUpdating = False
      For Each aRng In ActiveDocument.StoryRanges
      Select Case aRng.StoryType
    Case wdMainTextStory, wdFootnotesStory
        With aRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
        .MatchWildcards = False
        'Delete white spaces before paragraph breaks
        .Text = "^w^p"
        .Replacement.Text = "^p"
        .Execute Replace:=wdReplaceAll
        'Delete white spaces after paragraph breaks
        .Text = "^p^w"
        .Execute Replace:=wdReplaceAll
      .Forward = True
      .Wrap = wdFindContinue
      .MatchCase = False
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      Options.DefaultHighlightColorIndex = wdYellow
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
      .MatchCase = True
       'highlight yellow key house style words to check casing
      StrFnd = "Appendix,Annexure,Clause,Paragraph,Part,Schedule,Section,Regulation,Article,Company Number,Title Number,Registered Number,Registration Number,Registered Office,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That,Provided Always,Provided Further,per cent,per centum,percentum,chapter"
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
        .Text = Split(StrFnd, ",")(i) & "s"
        .Execute Replace:=wdReplaceAll
      Next
      .MatchCase = False
      'Highlight yellow figures written as words re 10 and above
      StrFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen,twenty,thirty,forty,fifty,sixty,sub-clause,sub clause,sub-paragraph,sub paragraph,"
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
      Options.DefaultHighlightColorIndex = wdTurquoise
      .MatchWildcards = True
      'highlight turquoise smart (curly) quotes and apostrophes, square brackets not in fields, manual digits & times
      .Text = "[0-9\[\]^0145^0146^0147^0148]{1,}"
      .Replacement.Text = "^&"
      .Execute Replace:=wdReplaceAll
      .Text = "<[ap].[m.]{1,2}"
      .Execute Replace:=wdReplaceAll
      .Text = "<[ap].[m]{1,2}"
      .Execute Replace:=wdReplaceAll
      'highlight turquoise spaces before comma, colon, semi-colon and full stop
     .Text = "[ ]([\,\:\;\.\?\!)])"
      .Execute Replace:=wdReplaceAll
        Options.DefaultHighlightColorIndex = wdGreen
        'Highlight green spaces after full stops,question marks and exclamation marks?
       .Text = "([.\?\!])[  ]"
       .Execute Replace:=wdReplaceAll
       Options.DefaultHighlightColorIndex = wdPink
       'Highlight pink where punctuation is missing?
       .Text = "([!^13.:;\?\!]^13)"
       .Font.Bold = False
       .Execute Replace:=wdReplaceAll
     End With
    'Highlight turquoise letters/digits within brackets in same paragraph re new sublevels
     Dim orng As Range
        Set orng = ActiveDocument.Range
        With orng.Find
            Do While .Execute(FindText:=" \([a-zA-Z0-9]{1,5}\) ", MatchWildcards:=True)
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        Set orng = ActiveDocument.Range
        With orng.Find
            Do While .Execute(FindText:=" \([a-z0-9]{1,5}\)^s", MatchWildcards:=True)
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise non-bold straight quotes
      Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = False
            Do While .Execute(FindText:=Chr(34))
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise bold apostrophes
         Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=Chr(44))
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise left bracket when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:="(")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        'highlight turquoise right bracket when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=")")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
         'highlight turquoise a colon when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=":")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
             'highlight turquoise a colon when bold
        Set orng = ActiveDocument.Range
        With orng.Find
            .Font.Bold = True
            Do While .Execute(FindText:=";")
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
    End Select
      Next aRng
      'does not highlight anything already in fields eg cross refs and square brackets
    ActiveWindow.View.ShowFieldCodes = True
      With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = False
        .Text = "^d"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
      ActiveWindow.View.ShowFieldCodes = False
      Application.ScreenUpdating = True
    End Sub

  2. #2
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,055
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Your snippet re-worked as a stand-alone macro:
    Code:
    Sub Demo()
    Application.ScreenUpdating = False
    Options.DefaultHighlightColorIndex = wdTurquoise
    With ActiveDocument.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Format = True
      .Forward = True
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      'highlight turquoise non-bold straight quotes
      .Font.Bold = False
      .Text = Chr(34)
      .Execute Replace:=wdReplaceAll
      'highlight turquoise bold apostrophes, parentheses, colons & semi-colons
      .Font.Bold = True
      .Text = "[" & Chr(44) & "\(\)\:\;]"
      .Execute Replace:=wdReplaceAll
    End With
    Application.ScreenUpdating = True
    End Sub
    I'll leave the integration to you.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  3. #3
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    Hi Macropod, thank you for sorting the code for me - this bit of the code is red Options.DefaultHighlightColorIndex = wdTurquoise With ActiveDocument.Range.Find and causing an error



    Code:
    Sub DPU_HouseStyleHighlight()
     'highlights body of doc and footnotes with following commands'
    Dim StrFnd As String, i As Long
      Dim aRng As Range
      Application.ScreenUpdating = False
      For Each aRng In ActiveDocument.StoryRanges
      Select Case aRng.StoryType
    Case wdMainTextStory, wdFootnotesStory
        With aRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
        .MatchWildcards = False
        'Delete white spaces before paragraph breaks
        .Text = "^w^p"
        .Replacement.Text = "^p"
        .Execute Replace:=wdReplaceAll
        'Delete white spaces after paragraph breaks
        .Text = "^p^w"
        .Execute Replace:=wdReplaceAll
      .Forward = True
      .Wrap = wdFindContinue
      .MatchCase = False
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      Options.DefaultHighlightColorIndex = wdYellow
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
      .MatchCase = True
       'highlight yellow key house style words to check casing
      StrFnd = "Appendix,Annexure,Clause,Paragraph,Part,Schedule,Section,Regulation,Article,Company Number,Title Number,Registered Number,Registration Number,Registered Office,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That,Provided Always,Provided Further,per cent,per centum,percentum,chapter"
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
        .Text = Split(StrFnd, ",")(i) & "s"
        .Execute Replace:=wdReplaceAll
      Next
      .MatchCase = False
      'Highlight yellow figures written as words re 10 and above
      StrFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen,twenty,thirty,forty,fifty,sixty,sub-clause,sub clause,sub-paragraph,sub paragraph,"
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
      Options.DefaultHighlightColorIndex = wdTurquoise
      .MatchWildcards = True
      'highlight turquoise smart (curly) quotes and apostrophes, square brackets not in fields, manual digits & times
      .Text = "[0-9\[\]^0145^0146^0147^0148]{1,}"
      .Replacement.Text = "^&"
      .Execute Replace:=wdReplaceAll
      .Text = "<[ap].[m.]{1,2}"
      .Execute Replace:=wdReplaceAll
      .Text = "<[ap].[m]{1,2}"
      .Execute Replace:=wdReplaceAll
      'highlight turquoise spaces before comma, colon, semi-colon and full stop
     .Text = "[ ]([\,\:\;\.\?\!)])"
      .Execute Replace:=wdReplaceAll
        Options.DefaultHighlightColorIndex = wdGreen
        'Highlight green spaces after full stops,question marks and exclamation marks?
       .Text = "([.\?\!])[  ]"
       .Execute Replace:=wdReplaceAll
       Options.DefaultHighlightColorIndex = wdPink
       'Highlight pink where punctuation is missing?
       .Text = "([!^13.:;\?\!]^13)"
       .Font.Bold = False
       .Execute Replace:=wdReplaceAll
     End With
    'Highlight turquoise letters/digits within brackets in same paragraph re new sublevels
     Dim orng As Range
        Set orng = ActiveDocument.Range
        With orng.Find
            Do While .Execute(FindText:=" \([a-zA-Z0-9]{1,5}\) ", MatchWildcards:=True)
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        Set orng = ActiveDocument.Range
        With orng.Find
            Do While .Execute(FindText:=" \([a-z0-9]{1,5}\)^s", MatchWildcards:=True)
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        Application.ScreenUpdating = False
    Options.DefaultHighlightColorIndex = wdTurquoise With ActiveDocument.Range.Find  .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Format = True
      .Forward = True
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      'highlight turquoise non-bold straight quotes
      .Font.Bold = False
      .Text = Chr(34)
      .Execute Replace:=wdReplaceAll
      'highlight turquoise bold apostrophes, parentheses, colons & semi-colo
      .Font.Bold = True
      .Text = "[" & Chr(44) & "\(\)\:\;]"
      .Execute Replace:=wdReplaceAll
    End With
    Application.ScreenUpdating = True
      Next aRng
      'does not highlight anything already in fields eg cross refs and square brackets
    ActiveWindow.View.ShowFieldCodes = True
      With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = False
        .Text = "^d"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
      ActiveWindow.View.ShowFieldCodes = False
      Application.ScreenUpdating = True
    End Sub

  4. #4
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,055
    Thanks
    2
    Thanked 417 Times in 346 Posts
    That's hardly surprising. Compare your code with what I posted. My code does not have all of
    Options.DefaultHighlightColorIndex = wdTurquoise With ActiveDocument.Range.Find
    on one line...
    Cheers,

    Paul Edstein
    [MS MVP - Word]

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

    Lady-Laughsalot (2016-11-17)

  6. #5
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    My apologises I copied it from the email I received rather than on here - all working fine now - many thanks for your help, macro seems much quicker now also. Shelley

  7. #6
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,055
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Quote Originally Posted by Lady-Laughsalot View Post
    macro seems much quicker now also.
    That's because the macro code I posted does in one DefaultHighlightColorIndex execution and two non-looped wildcard Find/Replace executions what your code took six HighlightColorIndex executions and six looped standard Find/Replace executions to do. The quite unnecessary looping would probably account for most of the difference. You should consider whether the rest of your code (which I haven't looked at) can likewise be made more efficient.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  8. #7
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    Hi Macropod, really appreciate your help, I'm not very good at coding, this macro just helps me a lot when converting documents to my firm's house style otherwise I'd be there forever finding all the highlighted parts I need to convert. If you could look at my coding at any time to see if it could be shortened I'd be really grateful. Thanks Shelley

    Code:
    Sub DPU_HouseStyleHighlight()
     'highlights body of doc and footnotes with following command'
    Dim StrFnd As String, i As Long
      Dim aRng As Range
      Application.ScreenUpdating = False
      For Each aRng In ActiveDocument.StoryRanges
      Select Case aRng.StoryType
    Case wdMainTextStory, wdFootnotesStory
        With aRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
        .MatchWildcards = False
        'Delete white spaces before paragraph breaks
        .Text = "^w^p"
        .Replacement.Text = "^p"
        .Execute Replace:=wdReplaceAll
        'Delete white spaces after paragraph breaks
        .Text = "^p^w"
        .Execute Replace:=wdReplaceAll
      .Forward = True
      .Wrap = wdFindContinue
      .MatchCase = False
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      Options.DefaultHighlightColorIndex = wdYellow
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
      .MatchCase = True
       'highlight yellow key house style words to check casing
      StrFnd = "Appendix,Annexure,Clause,Paragraph,Part,Schedule,Section,Regulation,Article,Company Number,Title Number,Registered Number,Registration Number,Registered Office,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That,Provided Always,Provided Further,per cent,per centum,percentum,chapter"
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
        .Text = Split(StrFnd, ",")(i) & "s"
        .Execute Replace:=wdReplaceAll
      Next
      .MatchCase = False
      'Highlight yellow figures written as words re 10 and above
      StrFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen,twenty,thirty,forty,fifty,sixty,sub-clause,sub clause,sub-paragraph,sub paragraph,"
      For i = 0 To UBound(Split(StrFnd, ","))
        .Text = Split(StrFnd, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
      Options.DefaultHighlightColorIndex = wdTurquoise
      .MatchWildcards = True
      'highlight turquoise smart (curly) quotes and apostrophes, square brackets not in fields, manual digits & times
      .Text = "[0-9\[\]^0145^0146^0147^0148]{1,}"
      .Replacement.Text = "^&"
      .Execute Replace:=wdReplaceAll
      .Text = "<[ap].[m.]{1,2}"
      .Execute Replace:=wdReplaceAll
      .Text = "<[ap].[m]{1,2}"
      .Execute Replace:=wdReplaceAll
      'highlight turquoise spaces before comma, colon, semi-colon and full stop
     .Text = "[ ]([\,\:\;\.\?\!)])"
      .Execute Replace:=wdReplaceAll
        Options.DefaultHighlightColorIndex = wdGreen
        'Highlight green spaces after full stops,question marks and exclamation marks?
       .Text = "([.\?\!])[  ]"
       .Execute Replace:=wdReplaceAll
       Options.DefaultHighlightColorIndex = wdPink
       'Highlight pink where punctuation is missing?
       .Text = "([!^13.:;\?\!]^13)"
       .Font.Bold = False
       .Execute Replace:=wdReplaceAll
     End With
    'Highlight turquoise letters/digits within brackets in same paragraph re new sublevels
     Dim orng As Range
        Set orng = ActiveDocument.Range
        With orng.Find
            Do While .Execute(FindText:=" \([a-zA-Z0-9]{1,5}\) ", MatchWildcards:=True)
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        Set orng = ActiveDocument.Range
        With orng.Find
            Do While .Execute(FindText:=" \([a-z0-9]{1,5}\)^s", MatchWildcards:=True)
                orng.HighlightColorIndex = wdTurquoise
                orng.Collapse 0
            Loop
        End With
        Application.ScreenUpdating = False
    Options.DefaultHighlightColorIndex = wdTurquoise
    With ActiveDocument.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Format = True
      .Forward = True
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      'highlight turquoise non-bold straight quotes
      .Font.Bold = False
      .Text = Chr(34)
      .Execute Replace:=wdReplaceAll
      'highlight turquoise bold apostrophes, parentheses, colons & semi-colon
      .Font.Bold = True
      .Text = "[" & Chr(44) & "\(\)\:\;]"
      .Execute Replace:=wdReplaceAll
    End With
    Application.ScreenUpdating = True
    End Select
      Next aRng
      'does not highlight anything already in fields eg cross refs and square brackets
    ActiveWindow.View.ShowFieldCodes = True
      With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = False
        .Text = "^d"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
      ActiveWindow.View.ShowFieldCodes = False
      Application.ScreenUpdating = True
    End Sub

  9. #8
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,055
    Thanks
    2
    Thanked 417 Times in 346 Posts
    You've evidently cobbled this together from various posts without giving it a proper structure or giving much thought to questions of integration. For example, there is not much point just slotting the code I provided above into your larger macro without considering how it's to be used. As written, the code I provided looked only at the main story only, but you have inserted it in a Select case statement that looks at both the main story and the footnotes story. You really should invest some time learning at least the basics of VBA coding.

    Try:
    Code:
    Sub DPU_HouseStyleHighlight()
    Application.ScreenUpdating = False
    'highlights body of doc and footnotes
    Dim StrFnd As String, i As Long, Rng As Range
    For Each Rng In ActiveDocument.StoryRanges
      With Rng
        Select Case .StoryType
          Case wdMainTextStory, wdFootnotesStory
            With Rng.Find
              .ClearFormatting
              .Replacement.ClearFormatting
              .Forward = True
              .MatchCase = True
              .Wrap = wdFindContinue
              .MatchWholeWord = True
              .MatchWildcards = False
              .MatchSoundsLike = False
              .MatchAllWordForms = False
              'Delete white spaces before paragraph breaks
              .Text = "^w^p"
              .Replacement.Text = "^p"
              .Execute Replace:=wdReplaceAll
              'Delete white spaces after paragraph breaks
              .Text = "^p^w"
              .Execute Replace:=wdReplaceAll
              .Replacement.Text = "^&"
              'Activate replacement highlighting
              .Replacement.Highlight = True
              'Set Highlight to Yellow
              Options.DefaultHighlightColorIndex = wdYellow
              'Highlight key house style words to check cases
              StrFnd = "Appendix,Annexure,Clause,Paragraph,Part,Schedule,Section,Regulation," & _
                "Article,Company Number,Title Number,Registered Number,Registration Number," & _
                "Registered Office,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That," & _
                "Provided Always,Provided Further,per cent,per centum,percentum,chapter"
              For i = 0 To UBound(Split(StrFnd, ","))
                .Text = Split(StrFnd, ",")(i)
                .Execute Replace:=wdReplaceAll
                .Text = Split(StrFnd, ",")(i) & "s"
                .Execute Replace:=wdReplaceAll
              Next
              .MatchCase = False
              'Highlight figures written as words re 10 and above
              StrFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen," & _
                "twenty,thirty,forty,fifty,sixty,sub-clause,sub clause,sub-paragraph,sub paragraph,"
              For i = 0 To UBound(Split(StrFnd, ","))
                .Text = Split(StrFnd, ",")(i)
                .Execute Replace:=wdReplaceAll
              Next
              'Activate wildcards
              .MatchWildcards = True
              'Set Highlight to Green
              Options.DefaultHighlightColorIndex = wdGreen
              'Highlight spaces after full stops,question marks and exclamation marks?
              .Text = "([.\?\!])[  ]"
              .Execute Replace:=wdReplaceAll
              'Set Highlight to Pink
              Options.DefaultHighlightColorIndex = wdPink
              'Highlight pink where punctuation is missing?
              .Text = "([!^13.:;\?\!]^13)"
              .Font.Bold = False
              .Execute Replace:=wdReplaceAll
              'Set Highlight to Turquoise
              Options.DefaultHighlightColorIndex = wdTurquoise
              'Highlight letters/digits within brackets in same paragraph re new sublevels
              .Text = "[ ^s]\([a-zA-Z0-9]{1,5}\)[ ^s]"
              .Execute Replace:=wdReplaceAll
              'Highlight smart (curly) quotes and apostrophes, square brackets not in fields & manual digits
              .Text = "[0-9\[\]^0145^0146^0147^0148]{1,}"
              .Execute Replace:=wdReplaceAll
              'Highlight times
              .Text = "<[ap].[m.]{1,2}"
              .Execute Replace:=wdReplaceAll
              .Text = "<[AP].[M.]{1,2}"
              .Execute Replace:=wdReplaceAll
              'Highlight spaces before comma, colon, semi-colon and full stop
              .Text = "[ ]([\,\:\;\.\?\!)])"
              .Execute Replace:=wdReplaceAll
              'Highlight non-bold straight quotes
              .Font.Bold = False
              .Text = Chr(34)
              .Execute Replace:=wdReplaceAll
              'Highlight bold apostrophes, parentheses, colons & semi-colon
              .Font.Bold = True
              .Text = "[" & Chr(44) & "\(\)\:\;]"
              .Execute Replace:=wdReplaceAll
              'Set Highlight to NoHighlight
              Options.DefaultHighlightColorIndex = wdNoHighlight
              'Don't highlight anything already in fields eg cross refs and square brackets
              ActiveWindow.View.ShowFieldCodes = True
              .MatchWildcards = False
              .Text = "^d"
              .Replacement.Text = ""
              .Execute Replace:=wdReplaceAll
              ActiveWindow.View.ShowFieldCodes = False
            End With
          Case Else
        End Select
      End With
    Next Rng
    Application.ScreenUpdating = True
    End Sub
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  10. #9
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    Hi Macropod - thank you so much for recoding my macro - I think you are right I definitely need to go and learn the basics of VBA at least because I do get myself in a bit of a muddle through lack of experience. I've just tested the new macro and everything works except it is highlighting anything in a field which it should not do. Shelley

  11. #10
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,055
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Try changing:
    Code:
              ActiveWindow.View.ShowFieldCodes = True
              .MatchWildcards = False
              .Text = "^d"
              .Replacement.Text = ""
              .Execute Replace:=wdReplaceAll
              ActiveWindow.View.ShowFieldCodes = False
    to:
    Code:
              ActiveWindow.View.ShowFieldCodes = True
              .ClearFormatting
              .MatchWildcards = False
              .Text = "^d"
              .Execute Replace:=wdReplaceAll
              ActiveWindow.View.ShowFieldCodes = False
    Cheers,

    Paul Edstein
    [MS MVP - Word]

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

    Lady-Laughsalot (2016-11-18)

  13. #11
    Star Lounger
    Join Date
    Aug 2015
    Posts
    98
    Thanks
    14
    Thanked 0 Times in 0 Posts
    Fabulous, all working now - thank you so much for your help. 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
  •