#1
|
|||
|
|||
VBA Highlight numbers only after or before specific words help
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 |
#2
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
VBA Highlight numbers only after or before specific words help
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 |
#4
|
||||
|
||||
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.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
VBA Highlight numbers only after or before specific words help
Hi Andrew, I did try the same thing before posting but it didn't work
Code:
.Text = "(" & arrA(i) & ")([ \^s])([A-Z0-9.]{1,})" Code:
iNum = UBound(Split(.text, ".")) If IsNumeric(Split(.text, ".")(UBound(Split(.text, ".")))) Then iNum = iNum + 1 If iNum < 10 Then .text = vbNullString |
#6
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#7
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
VBA Highlight numbers only after or before specific words help
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 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 |
#9
|
||||
|
||||
Quote:
Code:
ActiveWindow.ActivePane.View.ShowFieldCodes = True Code:
Application.ScreenUpdating = False Code:
ActiveWindow.ActivePane.View.ShowFieldCodes = False Code:
Application.ScreenUpdating = True
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
VBA Highlight numbers only after or before specific words help
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 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 |
#12
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#13
|
|||
|
|||
VBA Highlight numbers only after or before specific words help
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
|
Thread Tools | |
Display Modes | |
|
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 |