VBA Highlight numbers only after or before specific words help

[Shelley Lou]

Hi, I am trying to put together a macro that highlights the numbers only after the words in StrFndA and before the words in StrFndB - any numbers in a cross reference field should not be highlighted. The words in StrFndA and StrFndB may be plural and the numbers to highlight in StrFndA will be 1., 1.1, 1.1.1 etc.



I've put some code together, it doesn't work yet as it's not complete and would appreciate some guidance as I'm a little stuck on how to bring it all together and also add in code for StrFndB.

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