VBA help to update a highlight macro

Shelley Lou · #1 10-29-2021, 09:39 AM

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

Code:

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

Shelley Lou · #2 10-31-2021, 07:11 AM

Hi Guys, I posted a few days ago but posting again in the hope someone can help me and I don't have to cross post. I know I have received a lot of help from you guys in the past and I'm either just terrible at learning code or its just not sinking in. I know what I want it to do, I just can't seem to execute it well at all. I've literally gone through code I have in other macros to see if I can pick bits to add to this one and I have spent all weekend literally reading hundreds of posts but everything I try just isn't working. Am I on the right track with the partial codes below (I know they are incorrect), I'm trying to not use the global .Text = "[0-9]" that highlights every single digit in my document and limit what it does highlight. What do I need to add to implement this into the code I previously posted. It would be really helpful if comments were added so I can see the logic of what each step is doing so I can better understand the code and stop bothering you all so much. Much appreciate.

This Code

Code:

Dim strFnd As String, i As Long, Rng As Range, ArrFnd1, ArrFnd2, ArrFnd3, ArrWords1, ArrWords2

'NOT TO HIGHLIGHT IF DIGITS BEFORE OR AFTER THESE WORDS/DATES
'ArrFnd1 = ArrFnd = Array("[Mm]inute", "[Hh]our", "[Dd]ay", "[Ww]eek", "[Mm]onth", "[Yy]ear", "[Ww]orking", "[Bb]usiness", "Act", "section", "Rule", "Regulation, "Order")
'ArrFnd2 = Array ("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")

'TO ONLY HIGHLIGHT DIGITS AFTER THESE WORDS
'ArrFnd3 = Array("[Cc]lause", "[Pp]aragraph", "[Pp]art", "[Ss]chedule", "[Aa]ppendix", "[Aa]nnexure")

          Options.DefaultHighlightColorIndex = wdTurquoise
          .MatchCase = False
         .MatchWildcards = True
         For i = 0 To UBound(ArrFnd3)
         .Text = "(" & ArrFnd3(i) & "[ ^s][0-9.]{1,})" 'highlights if digits also have periods between them
         .Execute Replace:=wdReplaceAll
         .Text = ArrFnd3(i) & "s" & "[ ^s][0-9.]{1,}" 'and its plural
         .Execute Replace:=wdReplaceAll
         
         'Need to include if brackets follow e.g. clause 1.1(a)
         'Need to include digits if after 'to' and 'and' e.g. clauses 1 to 10
         
        Next

Or this Code

Code:

.Text = "(" & ArrFnd3(i) & "[ ^s][0-9]{1,})"
    .MatchWildcards = True
    .MatchCase = False
    .MatchWholeWord = True
    While .Execute
      Select Case oRng.Start
        Case 0
          oRng.HighlightColorIndex = wdTurquoise
        Case 1
          If Not oRng.Characters.First.Previous.Text Like "ArrFnd1" Then
            oRng.HighlightColorIndex = wdNoHighlight
          End If
        Case Else
      End Select
    Wend

'FIND CASE AND HIGHLIGHT

Code:

ArrWords1 = Array("this Lease", "this Agreement", "this Deed", "this Contract")
ArrWords2 = Array("this lease", "this agreement", "this deed", "this contract")
For i = 0 To UBound(ArrWords1)
Set oRng = ActiveDocument.Range
  With oRng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "ArrWords1(i)" 'Can this be found in the document - if yes - search doc for instances of lowercase not bold and highlight yellow e.g. this lease
  .Font.Bold = True     'If no - change search to look for lowercase bold (ArrWords2) and highlight instances of e.g. this Lease
  .MatchCase = True
  While .Execute
  'Now find any instances of lowercase not formatted bold
  If oRng.Characters.Last.Text = wdLowerCase Then
  oRng.Characters.Last.Font.Bold = False
  oRng.HighlightColorIndex = wdYellow
  'or if ArrFnd2 is lowercase search for last word title case
End If
    Wend

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to highlight a list of words	bakerkr	Word VBA	4	10-19-2017 02:23 PM
Macro Question: Need help making a macro to highlight the first word in every sentence	LadyAna	Word	1	12-06-2014 10:39 PM
Macro to highlight words	bertietheblue	Word VBA	9	07-01-2013 12:39 PM
Trying to highlight pasted text in a macro	goldengate	Word VBA	0	09-14-2010 09:41 PM
find - reading highlight - highlight all / highlight doesn't stick when saved	bobk544	Word	3	04-15-2009 03:31 PM