Sub DemoB()
Application.ScreenUpdating = True
Dim StrFndA As String, StrFndB As String, i As Long, Rng As Range
StrFndA = "[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words
StrFndB = "[Mm]inute,[Hh]our,[Dd]ay,[Ww]eek,[Mm]onth,[Yy]ear,[Ww]orking,[Bb]usiness" 'highlight numbers before these words
For Each Rng In ActiveDocument.StoryRanges
  With Rng
    Select Case .StoryType
      Case wdMainTextStory, wdFootnotesStory
        For i = 0 To UBound(Split(StrFndA, ","))
          With .Duplicate
            With .Find
              .ClearFormatting
              .Replacement.ClearFormatting
              .Forward = True
              .Wrap = wdFindStop
              .MatchWildcards = True
              .Text = Split(StrFndA, ",")(i) & "[s ^s]@[0-9.]{1,}"
            End With
            Do While .Find.Execute
              .MoveStart wdWord, 1
              .HighlightColorIndex = wdTurquoise
              .Collapse wdCollapseEnd
            Loop
          End With
        Next
        For i = 0 To UBound(Split(StrFndB, ","))
          With .Duplicate
            With .Find
              .ClearFormatting
              .Replacement.ClearFormatting
              .Forward = True
              .Wrap = wdFindStop
              .MatchWildcards = True
              .Text = "[0-9]{1,}[ ^s]" & Split(StrFndB, ",")(i)
            End With
            Do While .Find.Execute
              .MoveEnd wdWord, -1
              .End = .End - 1
              .HighlightColorIndex = wdTurquoise
              .Collapse wdCollapseEnd
            Loop
          End With
        Next
      Case Else
    End Select
  End With
Next Rng
Application.ScreenUpdating = True
End Sub