Sub HighlightNumbers()
Application.ScreenUpdating = False
Dim StrFndA As String, StrFndB As String, i As Long, Rng As Range
StrFndA = "clause,paragraph,part,schedule" 'highlight numbers after these words
StrFndB = "minute,hour,day,week,month,year,working,business" 'highlight numbers before these words
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
          .Replacement.Highlight = True
          
          For i = 0 To UBound(Split(StrFndA, ","))
            .text = Split(StrFndA, ",")(i) & "[0-9]"
            .Execute Replace:=wdReplaceAll
            .text = Split(StrFndA, ",")(i) & "s" & "[0-9]"
            .Execute Replace:=wdReplaceAll
          Next
          Do While .Find.Found
          .Start = .Words.First.End
          If .text > .Paragraphs.First.Range.ListFormat.ListString Then
         .HighlightColorIndex = wdTurquoise
         End If
        .Find.Execute
         Loop
         
          Options.DefaultHighlightColorIndex = wdNoHighlight
          ActiveWindow.View.ShowFieldCodes = True 'Don't highlight cross refs already in fields
          .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