![]() |
|
![]() |
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
![]()
This code was generated using Copilot AI but it's so slow it doesn't terminate:
Code:
Sub HighlightUnhighlightedInstancesOfHighlightedWords() Dim doc As Document Dim rng As Range Dim findText As String Dim highlightColor As Long Dim tempRng As Range Dim startPos As Long Set doc = ActiveDocument ' Loop through each word in the document For Each rng In doc.Words If rng.HighlightColorIndex <> wdNoHighlight Then ' Store the highlighted word and its highlight color findText = Trim(rng.Text) highlightColor = rng.HighlightColorIndex ' Find all instances of the highlighted word Set tempRng = doc.Content With tempRng.Find .ClearFormatting .Text = findText .Format = True .MatchWholeWord = True .MatchCase = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Forward = True .Wrap = wdFindStop Do While .Execute ' Check if the found instance is not already highlighted If tempRng.HighlightColorIndex = wdNoHighlight Then tempRng.HighlightColorIndex = highlightColor End If ' Move the range past the found instance startPos = tempRng.End tempRng.Collapse wdCollapseEnd tempRng.Start = startPos tempRng.End = doc.Content.End Loop End With End If Next rng End Sub Last edited by macropod; 10-08-2024 at 02:23 PM. Reason: Added code tags |
#2
|
||||
|
||||
![]()
Isn't AI wonderful ◔◔. Try the following:
Code:
Sub MatchHighlight() 'Graham Mayor - https://www.gmayor.com - Last updated - 08 Oct 2024 Dim oDoc As Document Dim oRng As Range Dim oCol As Collection Dim i As Integer Set oDoc = ActiveDocument Set oRng = oDoc.Range Set oCol = New Collection With oRng.Find .ClearFormatting .Replacement.ClearFormatting .Highlight = True Do While .Execute = True oCol.Add oRng.Text & "/" & oRng.HighlightColorIndex, _ oRng.Text & "/" & oRng.HighlightColorIndex oRng.Collapse 0 Loop End With For i = 1 To oCol.Count Set oRng = oDoc.Range With oRng.Find .ClearFormatting .Replacement.ClearFormatting .Text = Split(oCol(i), "/")(0) Do While .Execute = True oRng.HighlightColorIndex = Split(oCol(i), "/")(1) oRng.Collapse 0 Loop End With Next i lbl_Exit: Set oDoc = Nothing Set oRng = Nothing Set oCol = Nothing Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
![]()
This is amazing, thanks so much!
|
#4
|
|||
|
|||
![]()
In some documents it generates this error:
The key is already highlighted with an element of this collection. The debugger highlights this code: oCol.Add oRng.Text & "/" & oRng.HighlightColorIndex, _ oRng.Text & "/" & oRng.HighlightColorIndex |
#5
|
|||
|
|||
![]()
Hi, MUMS!
Just insert Code:
On Error Resume Next Code:
oCol.Add oRng.Text & "/" & oRng.HighlightColorIndex, _ oRng.Text & "/" & oRng.HighlightColorIndex |
#6
|
|||
|
|||
![]()
While Vika's suggestion will work, it is not really necessary. The issue is the collection "key" attribute is being used when it doesn't necessarily need to be. Also, the code as Graham wrote will also highlight partial text in other words. That may or not be suitable for your needs. E.g., This is a test. I can attest that if you highlight "test" and run the code that at"test" will also be highlighted. You might consider:
Code:
Sub MatchHighlight() 'Graham Mayor - https://www.gmayor.com - Last updated - 08 Oct 2024 Dim oDoc As Document Dim oRng As Range Dim oCol As Collection Dim i As Integer Set oDoc = ActiveDocument Set oRng = oDoc.Range Set oCol = New Collection With oRng.Find .ClearFormatting .Replacement.ClearFormatting .Highlight = True .MatchWholeWord = True '*** GKM mod Do While .Execute = True oCol.Add oRng.Text & "/" & oRng.HighlightColorIndex '*** GKM mod oRng.Collapse 0 Loop End With For i = 1 To oCol.Count Set oRng = oDoc.Range With oRng.Find .ClearFormatting .Replacement.ClearFormatting .MatchWholeWord = True '*** GKM mod .Text = Split(oCol(i), "/")(0) Do While .Execute = True oRng.HighlightColorIndex = Split(oCol(i), "/")(1) oRng.Collapse 0 Loop End With Next i lbl_Exit: Set oDoc = Nothing Set oRng = Nothing Set oCol = Nothing Exit Sub End Sub |
#7
|
|||
|
|||
![]()
Greg and Graham, let me put in my two cents' worth. I compiled the code, which may seem quite primitive, a while ago, but didn't want to hijack the thread for ethical reasons. Now that Greg posted his code, I think I will not hurt anyone's feelings.
Code:
Sub Hilite_All_Instances() 'In selection, hilite all plain occurrences of the hilited strs 'in their respective colors. Dim oSel As range Dim oRng As range Application.ScreenUpdating = False Set oSel = selection.range Set oRng = selection.range Do selection.range.Find.ClearFormatting selection.range.Find.Replacement.ClearFormatting With oRng.Find .Highlight = True If .Execute And oRng.InRange(selection.range) Then ClrFind = oRng.HighlightColorIndex Set oSel = selection.range With oSel.Find .text = oRng .MatchCase = True .MatchWholeWord = True .MatchWildcards = False .Forward = True .Wrap = wdFindStop While .Execute And oSel.InRange(selection.range) oSel.HighlightColorIndex = ClrFind Wend End With Else: Exit Do End If End With Loop Application.ScreenUpdating = True Set oSel = Nothing Set oRng = Nothing End Sub |
#8
|
|||
|
|||
![]()
Vika,
Speaking only for myself, I don't see posting alternative solutions as "hijacking" the post. I think we all learn from the experience and examples of others. That said, I have always (and I don't really know why) have had an aversion to using "Selection" Here is another alternative that sort of combines Graham's collection and your process: Code:
Dim oCol As New Collection Dim clrfind Dim oRng As Range, oRngSub As Range Application.ScreenUpdating = False Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .Highlight = True .Wrap = wdFindStop While .Execute On Error Resume Next oCol.Add oRng.Text, oRng.Text If Err.Number = 0 Then clrfind = oRng.HighlightColorIndex Set oRngSub = ActiveDocument.Range oRngSub.Start = oRng.End With oRngSub.Find .Text = oRng .MatchCase = True .MatchWholeWord = True While .Execute oRngSub.HighlightColorIndex = clrfind Wend End With oRng.Collapse wdCollapseEnd Else Err.Clear End If Wend End With Application.ScreenUpdating = True Set oRng = Nothing: Set oRngSub = Nothing End Sub Here we do use the collection key to bypass words that have already processed. |
#9
|
|||
|
|||
![]()
Thank you, Greg, for another interesting solution! I'll keep it in my collection of macros.
|
#10
|
|||
|
|||
![]()
Works great, thanks a lot. I wish I had asked to also turn the highlight color to red if no other instances of a highlighted word are found.
|
#11
|
|||
|
|||
![]()
Don't have a lot of time to test but you can try:
Code:
Sub ScratchMacro() 'A basic Word Macro coded by Gregory K. Maxey Dim oCol As New Collection Dim clrfind Dim oRng As Range, oRngSub As Range, oRngFF As Range Dim bOne As Boolean Application.ScreenUpdating = False Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .Highlight = True .Wrap = wdFindStop While .Execute Set oRngFF = oRng.Duplicate bOne = True On Error Resume Next oCol.Add oRng.Text, oRng.Text If Err.Number = 0 Then clrfind = oRng.HighlightColorIndex Set oRngSub = ActiveDocument.Range oRngSub.Start = oRng.End With oRngSub.Find .Text = oRng .MatchCase = True .MatchWholeWord = True While .Execute bOne = False oRngSub.HighlightColorIndex = clrfind Wend End With oRng.Collapse wdCollapseEnd If bOne Then oRngFF.HighlightColorIndex = wdNoHighlight oRngFF.HighlightColorIndex = wdRed End If Else Err.Clear End If Wend End With Application.ScreenUpdating = True Set oRng = Nothing: Set oRngSub = Nothing lbl_Exit: Exit Sub End Sub |
#12
|
|||
|
|||
![]()
Works great. Thanks for your time and effort.
|
![]() |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Copy highlighted words from Word Document to designated Excel file | syl3786 | Word VBA | 2 | 07-26-2023 11:56 PM |
![]() |
hcl75 | Word VBA | 3 | 10-08-2022 02:39 PM |
How to point a macro that highlights from a string of words at the footnotes rather than main doc | poggyton | Word VBA | 4 | 10-15-2019 06:19 PM |
![]() |
angiesnow | Word | 2 | 08-12-2018 03:40 AM |
![]() |
BABZ | Word VBA | 1 | 01-09-2017 10:33 PM |