Sub HighlightNumbers()
  Dim StrFndA As String, StrFndB As String, i As Long, Rng As Range
  Dim arrA() As String, arrB() As String
  
  StrFndA = "Clause,Paragraph,Part,Schedule" 'highlight numbers after these words 'use initial caps
  StrFndB = "Minute,Hour,Day,Week,Month,Year,Working,Business" 'highlight numbers before these words  'use initial caps
  arrA = Split(StrFndA & "," & LCase(StrFndA), ",")   'both initial cap and lowercase versions of words
  arrB = Split(StrFndB & "," & LCase(StrFndB), ",")   'both initial cap and lowercase versions of words
  
  'Application.ScreenUpdating = False
  For Each Rng In ActiveDocument.StoryRanges
    With Rng
      Select Case .StoryType
        Case wdMainTextStory, wdFootnotesStory
          With Rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindContinue
            .MatchWholeWord = False
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            
            For i = 0 To UBound(arrA)
              .Text = "(" & arrA(i) & ")([ \^s])([A-Z0-9.]{1,})"
              .Replacement.Text = "\1 <<\3>>"
              .Execute Replace:=wdReplaceAll
              .Text = "(" & arrA(i) & "s)([ \^s])([A-Z0-9.]{1,})"
              .Execute Replace:=wdReplaceAll
            Next
            
            For i = 0 To UBound(arrB)
              .Text = "([0-9]{1,}) (" & arrB(i) & ")"
              .Replacement.Text = "<<\1>> \2"
              .Execute Replace:=wdReplaceAll
            Next
            
            Options.DefaultHighlightColorIndex = wdTurquoise
            .Replacement.Highlight = True
            .MatchWildcards = True
            .Text = "\<\<[A-Z0-9.]{1,}\>\>"
            .Replacement.Text = ""
            .Execute Replace:=wdReplaceAll
            
            .Replacement.ClearFormatting
            .MatchWildcards = False
            .Text = "<<"
            .Execute Replace:=wdReplaceAll
            .Text = ">>"
            .Execute Replace:=wdReplaceAll
            
          End With
        Case Else
      End Select
    End With
  Next Rng
  Application.ScreenUpdating = True
End Sub