A Word macro that highlights all other instances of words that are already highlighted

MUMS · #1 10-08-2024, 12:31 AM

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

gmayor · #2 10-08-2024, 02:25 AM

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

MUMS · #3 10-08-2024, 02:40 AM

This is amazing, thanks so much!

MUMS · #4 10-09-2024, 01:04 AM

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

vivka · #5 10-09-2024, 07:57 AM

Hi, MUMS!
Just insert

Code:

On Error Resume Next

before

Code:

oCol.Add oRng.Text & "/" & oRng.HighlightColorIndex, _
                      oRng.Text & "/" & oRng.HighlightColorIndex

gmaxey · #6 10-10-2024, 04:46 AM

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

vivka · #7 10-10-2024, 06:40 AM

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

PS. The code doesn't use a collection, doesn't care about recoloring source words, and works on a selected range, which to my mind is more practical. To use it on a whole doc, one should press Ctrl+A before running the code. Greg's way of using a collection was new to me. Thank you, Greg! I live and learn.

gmaxey · #8 10-10-2024, 10:22 AM

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.

vivka · #9 10-10-2024, 10:36 AM

Thank you, Greg, for another interesting solution! I'll keep it in my collection of macros.

MUMS · #10 10-12-2024, 01:57 AM

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.

gmaxey · #11 10-12-2024, 05:04 AM

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

MUMS · #12 10-13-2024, 01:17 AM

Works great. Thanks for your time and effort.

Similar Threads
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
How to use Word Macro to change all highlighted words as mark-up?	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
Is this even possible: extrapolating highlighted words	angiesnow	Word	2	08-12-2018 03:40 AM
Macro in Word to track colour of highlighted text	BABZ	Word VBA	1	01-09-2017 10:33 PM