VBA help to update a highlight macro

[Shelley Lou]

I have been using the following highlight macro for a few years now which helps me identify any house style changes that need to be made regarding case, cross references, manual numbering etc. The only problem is that it highlights every single digit in the document from dates to Acts etc. and its starting to look very messy, so its time it had an update. I would like the macro to do the following:



Highlight test doc.doc

1. Highlight manual digits that only follow words like 'clause, paragraph, part, schedule' in an array (so I can add more if needed) (e.g. clause 1.1)

2. Highlight manual digits at the beginning of paragraphs to see if auto numbering has been missed.

3. The highlight pink for missing punctuation at end of paragraphs needs to include where they appear in tables.

4. Highlight pink sublevels that end with a comma or space before the words 'or, and, but, then' – but not if they already end with a semi-colon followed by the words 'or, and, but, then'.

5. The missing punctuation highlight doesn't work if the paragraph ends with a field e.g. cross reference field so it would be good to add this also.

6. To only highlight the words 'clause, paragraph, part, schedule, appendix, plan' if they are followed by a digit – currently the code looks for every instance e.g. Common Parts, Schedule of Condition which do not need to be highlighted.

7. There is a section in the code that highlights instances of letters/digits in parentheses (e.g.) (a), (A), (1), (ii) that appear within the body of a paragraph to alert me if these should be sublevels and need to be renumbered – I expect this could be coded better.

8. Often in legal documents the words "this Lease", "this Agreement" (as examples) are defined but both title case and lowercase may be found within the document. Is there a way to tell the code to look for these defined terms and highlight only if they appear as lowercase.
The reverse may also be the case e.g. defined as lowercase "this lease", "this agreement" so the code would need to highlight any in title case if the defined terms are lowercase.

defined term.PNG

As always, any help with this is always appreciated. Thanks

Sub HouseStyleHighlight()
Application.ScreenUpdating = False
Dim strFnd As String, i As Long, Rng As Range, ArrFnd

'Only highlight digits AFTER these words in the array and include if digit is followed by e.g. 1.1(a), 1(A), 1.1(a)(i), 1.1(a)(i)(A)(1)
ArrFnd = Array("[Cc]lause", "[Pp]aragraph", "[Pp]Part", "[Ss]hedule", "[Aa]rticle", "[Aa]ppendix", "[Pp]lan")

'To only highlight the words clause, paragraph, part or schedule if they are followed by a digit
ArrFnd = Array("[Cc]lause", "[Pp]aragraph", "[Pp]Part", "[Ss]hedule", "[Aa]rticle", [Aa]ppendix", "[Pp]lan")

For Each Rng In ActiveDocument.StoryRanges                      'highlights body of doc and footnotes
  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
          .Text = "^w^p"                                        'Delete white spaces before paragraph breaks
          .Replacement.Text = "^p"
          .Execute Replace:=wdReplaceAll
          .Text = "^p^w"                                        'Delete white spaces after paragraph breaks
          .Replacement.Text = "^&"
          .Execute Replace:=wdReplaceAll
          .Replacement.Highlight = True                         'Activate replacement highlighting
     
          Options.DefaultHighlightColorIndex = wdYellow         'Set Highlight to Yellow
           strFnd = "Registered Office,PROVIDED,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That,Provided Always,Provided Further,Provided that, " & _
           "Provided further,Provided Further That,per cent,percent,per centum,percentum,chapter,percentage points,Means,means,Appendix,Annexure,Appendices,Clause,Paragraph,Part,Schedule,Section,Regulation,Rule,Article," & _
           "Company Number,Company number,Title Number,Registered Number,Registration Number,sub-clause,sub clause,subclause,sub-paragraph,sub paragraph,subparagraph"
          For i = 0 To UBound(Split(strFnd, ","))               'Highlight key house style words to check case
            .Text = Split(strFnd, ",")(i)
            .Execute Replace:=wdReplaceAll
            .Text = Split(strFnd, ",")(i) & "s"
            .Execute Replace:=wdReplaceAll
          Next
          Options.DefaultHighlightColorIndex = wdTurquoise       'Highlight figures written as words
         strFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen," & _
          "twenty,twenty one,twenty four,thirty,forty,forty eight,fifty,sixty,seventy,eighty,ninety,tenth,eleventh,twelfth,thirteenth,fourteenth,fifteenth,sixteenth," & _
          "seventeenth,eighteenth,nineteenth,twentieth"
          For i = 0 To UBound(Split(strFnd, ","))
            .Text = Split(strFnd, ",")(i)
            .Execute Replace:=wdReplaceAll
            .Text = Split(strFnd, ",")(i) & "s"
            .Execute Replace:=wdReplaceAll
        Next
          .MatchWildcards = True                                 'Activate wildcards
          Options.DefaultHighlightColorIndex = wdPink            'Set Highlight to Pink
          .Text = "([!^13.,:;\?\!]^13)"                          'Highlight pink where punctuation is missing (including tables)
          .Font.Bold = False
          .Execute Replace:=wdReplaceAll
                    
          '.Text = "([,]) ([a-z])"                                'Only highlight if para ends with comma or space before 'or, and, but, then' (including tables)
          '.Execute Replace:=wdReplaceAll
          
          Options.DefaultHighlightColorIndex = wdTurquoise
         ' .Text = "[0-9]"                                        'Only highlight manual digits if at beginning of paragraph
         ' .Execute Replace:=wdReplaceAll
          .Text = "([0-9][dhnrst]{2})"                           'Highlight ordinal numbers
          .Execute Replace:=wdReplaceAll
          .Text = "[ ^s]\([a-zA-Z0-9]{1,5}\)[ ^s\,\.\;]"         'Highlight manual letters/digits in brackets e.g. (a), (A, (i), (iv)
          .Execute Replace:=wdReplaceAll
          .Text = "([\(][A-Za-z0-9][\)][^09^32])(*)"
          .Execute Replace:=wdReplaceAll
          .Text = "([\(][A-Za-z0-9][A-Za-z0-9][\)][^09^32])(*)"
          .Execute Replace:=wdReplaceAll
          .Text = "([\(][A-Za-z][A-Za-z][A-Za-z][\)][^09^32])(*)"
          .Execute Replace:=wdReplaceAll
          .Text = "([\(][A-Za-z][A-Za-z][A-Za-z][A-Za-z][\)][^09^32])(*)"
          .Execute Replace:=wdReplaceAll
          .Text = "([^09^32][\(][A-Za-z0-9][\)])(*)"
          .Execute Replace:=wdReplaceAll
          .Text = "<[ap].[m.]{1,2}"                              'Highlight times
          .Execute Replace:=wdReplaceAll
          .Text = "<[AP].[M.]{1,2}"
          .Execute Replace:=wdReplaceAll
          
          Options.DefaultHighlightColorIndex = wdGreen           'Set Highlight to Green
          .Text = "([.\?\!]) ([A-Z])"                            'Highlight when only one space after punctuation/end of sentence?
          .Execute Replace:=wdReplaceAll
          
          Options.DefaultHighlightColorIndex = wdBrightGreen     'Set Highlight to Bright Green
          .Text = "([;])"                                        'Highlight semi-colons
          .Execute Replace:=wdReplaceAll
          .Text = "[^0145^0146^0147^0148]{1,}"                   'Highlight smart (curly) quotes and apostrophes, square brackets not in fields
          .Execute Replace:=wdReplaceAll
          .Text = "[ ]([\)\]\\-\,\:\;\.\?\!)])"                  'Highlight spaces before punctuation
          .Execute Replace:=wdReplaceAll
          .Font.Bold = False                                     'Highlight non-bold straight quotes
          .Text = Chr(34)
          .Execute Replace:=wdReplaceAll
          .Font.Bold = True                                      'Highlight bold smart apostrophes/quotes/parentheses/colons/semi-colons/full stops
          .Text = "[" & Chr(44) & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "\(\)\[\]\:\;\.\'\,]"
          .Execute Replace:=wdReplaceAll
          
          'FOLLOWING NOT BE HIGHLIGHTED
          Options.DefaultHighlightColorIndex = wdNoHighlight    'Set Highlight to NoHighlight
           ActiveWindow.View.ShowFieldCodes = True              'Ignore anything in fields eg cross refs/square brackets/hyperlinks
          .ClearFormatting
          .MatchWildcards = False
          .Text = "^d"
          .Execute Replace:=wdReplaceAll
          ActiveWindow.View.ShowFieldCodes = False
        End With
      Case Else
    End Select
  End With
Next Rng
Application.ScreenUpdating = True
End Sub