VBA Highlight numbers only after or before specific words help

Shelley Lou · #1 08-04-2022, 08:17 AM

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.

Code:

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

Guessed · #2 08-04-2022, 07:58 PM

This is my approach. I think your strA variables might also be followed by a capital letter (eg Part A, Section B) so I included that possibility.
This approach is to firstly tag all target numbers with by enclosing in findable 'unique brackets'. Then running a separate replace to highlight them, then remove the unique brackets. Because a wildcard search is case sensitive, you need to build the array with both initial cap and lowercase variants.

Code:

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) & ") ([A-Z0-9]{1,})"
              .Replacement.Text = "\1 <<\2>>"
              .Execute Replace:=wdReplaceAll
              .Text = "(" & arrA(i) & "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
            
            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

Shelley Lou · #3 08-04-2022, 11:40 PM

Hi Andrew, thank you so much for updating the code it is very much appreciated. After testing it a few times I don't think the fields part I added needs to be in there as your code doesn't actually pick them up anyway so I have removed that part.

If there is a non-breaking space between the word and number the code isn't picking this up, I've tried adding in ([ \^s]) but this just removed the number so I need to add in if there is a space or non-breaking space.

Is there a way to include all the numbers for sub levels 1.1, 1.1.1 and 1.1.1.1 as it only seems to pick up the first number at the moment.

highlight.PNG

Guessed · #4 08-05-2022, 01:21 AM

If you are adding another find element inside (brackets) then you will need to account for that shift in the replace with value. For example:
.Text = "(" & arrA(i) & ") ([A-Z0-9]{1,})"
changing to
.Text = "(" & arrA(i) & ")([ \^s])([A-Z0-9]{1,})"
means that you also need to change the replace with to
.Replacement.Text = "\1 <<\3>>"

You can include extra parts of the number by including the stops in the wildcard search
.Text = "(" & arrA(i) & ")([ \^s])([A-Z0-9.]{1,})"

However you may find that if the phrase ends with a stop immediately after the number then it will also be included in the highlighted range.

Shelley Lou · #5 08-05-2022, 01:57 AM

Hi Andrew, I did try the same thing before posting but it didn't work

Code:

.Text = "(" & arrA(i) & ")([ \^s])([A-Z0-9.]{1,})"

Maybe it needs an IF...Then - code below is taken from an auto numbering macro I have and wondering if it could be adapted for my highlight purpose perhaps

Code:

iNum = UBound(Split(.text, "."))
If IsNumeric(Split(.text, ".")(UBound(Split(.text, ".")))) Then iNum = iNum + 1
If iNum < 10 Then
.text = vbNullString

Guessed · #6 08-05-2022, 04:56 PM

There are subtle changes to this code and it appears to work on my machine. Note the addition of the stop when applying the highlight - perhaps that was where your code was missing the element.

Code:

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

macropod · #7 08-05-2022, 06:33 PM

Here are two simplified approaches you might try. The first highlights only those numbers that stand alone (e.g. Clause 23, but not Clause 2.2), whereas the second highlights both. Note the wildcard expressions used to capture both cases and plurals.

Code:

Sub DemoA()
Application.ScreenUpdating = False
Dim StrFndA As String, i As Long, Rng As Range
StrFndA = "[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after 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 ]@[0-9]@>[. ][!0-9]"
            End With
            Do While .Find.Execute
              .Start = .Words(2).Start
              .End = .Words.First.End
              .HighlightColorIndex = wdBrightGreen
              .Collapse wdCollapseEnd
            Loop
          End With
        Next
      Case Else
    End Select
  End With
Next Rng
Application.ScreenUpdating = True
End Sub

Code:

Sub DemoB()
Application.ScreenUpdating = False
Dim StrFndA As String, i As Long, Rng As Range
StrFndA = "[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" '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
        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 ]@[0-9.]{1,}"
            End With
            Do While .Find.Execute
              .Start = .Words(2).Start
              .HighlightColorIndex = wdYellow
              .Collapse wdCollapseEnd
            Loop
          End With
        Next
      Case Else
    End Select
  End With
Next Rng
Application.ScreenUpdating = True
End Sub

Shelley Lou · #8 08-08-2022, 01:19 AM

Thank you Andrew and Macropod for taking the time to share your code, it is very much appreciated.

Macropod, I have just run DemoB and works perfectly if there are no cross reference fields within the document but appears to bug if there are cross reference fields.

Code:

.Start = .Words(2).Start

I have a second string (StrFndB) that should highlight digits before those words but not sure how to add that to your second code (DemoB).

Code:

Sub DemoB()
Application.ScreenUpdating = False
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
              .Start = .Words(2).Start
              .HighlightColorIndex = wdTurquoise
              .Collapse wdCollapseEnd
            Loop
          End With
        Next
      Case Else
    End Select
  End With
Next Rng
Application.ScreenUpdating = True
End Sub

macropod · #9 08-08-2022, 06:55 AM

Quote:

Originally Posted by Shelley Lou

Macropod, I have just run DemoB and works perfectly if there are no cross reference fields within the document but appears to bug if there are cross reference fields.

Code:

.Start = .Words(2).Start

You could insert:

Code:

ActiveWindow.ActivePane.View.ShowFieldCodes = True

after:

Code:

Application.ScreenUpdating = False

and:

Code:

ActiveWindow.ActivePane.View.ShowFieldCodes = False

before:

Code:

Application.ScreenUpdating = True

macropod · #10 08-08-2022, 07:01 AM

For the second process you might insert:

Code:

        For i = 0 To UBound(Split(StrFndB, ","))
          With .Duplicate
            With .Find
              .ClearFormatting
              .Replacement.ClearFormatting
              .Forward = True
              .Wrap = wdFindStop
              .MatchWildcards = True
              .Text = "[0-9.]{1,} " & Split(StrFndB, ",")(i)
            End With
            Do While .Find.Execute
              .End = .Words(.Words.Count).Start - 1
              .HighlightColorIndex = wdYellow
              .Collapse wdCollapseEnd
            Loop
          End With
        Next

It seems doubtful that you would need to consider capitalization in those cases, though.

Shelley Lou · #11 08-08-2022, 08:58 AM

Hi Macropod, I have added the second process to the code and that is working fine when there are no cross reference fields but even after adding the other two lines of code it is still bugging with error 5941 if there are cross reference fields - I have added a test document so you can see what is happening.

Code:

.Start = .Words(2).Start

Highlight numbers after or before.docx

Code:

Sub DemoB()
Application.ScreenUpdating = False
ActiveWindow.ActivePane.View.ShowFieldCodes = 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
              .Start = .Words(2).Start
              .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
              .End = .Words(.Words.Count).Start - 1
              .HighlightColorIndex = wdTurquoise
              .Collapse wdCollapseEnd
            Loop
          End With
        Next
      Case Else
    End Select
  End With
Next Rng
ActiveWindow.ActivePane.View.ShowFieldCodes = False
Application.ScreenUpdating = True
End Sub

macropod · #12 08-08-2022, 04:00 PM

Try:

Code:

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

Note that the code now also tests for non-breaking spaces - which your document has but you hadn't mentioned.

Shelley Lou · #13 08-09-2022, 03:02 AM

Hi Macropod, thank you so much for this have tested it a few times and all working great - I did update your code previously to include non breaking spaces but didn't realise I didn't need the \ to separate space and non breaking space so many thanks for updating that also. Regards, Shelley

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Highlight numbers after a specific word in numbered list	liblikas90	Word VBA	3	02-27-2019 03:52 AM
How to highlight lines containing specific words	SixStringSW	Word VBA	4	06-03-2018 03:57 PM
How to find (highlight) two and more words in a list of 75k single words in Word 2010	Usora	Word	8	05-29-2018 03:34 AM
Search a cell that contains words and numbers and convert the numbers to metric	Carchee	Excel Programming	36	10-08-2014 03:16 PM
VBA to highlight words if used too much	aolszewski	Word VBA	3	11-23-2013 02:07 AM