Microsoft Office Forums - View Single Post - Highlight / Shading list of repeating words to include seaparte color for first instance

KoryGrayson · 12-07-2024, 04:17 PM

Hello.

I modified a code that was posted earlier to highlight a list of items that I keep in a separate spreadsheet. The code works fine. However, I was hoping to tweak it to do the items listed below as well:

1. Do shading instead of highlighting.
I prefer to do this, since it highlights the whole row in my Word document instead of highlighting just the one word. I want each row where the word is listed to be shaded.
Currently, I am doing a work around where I go back and change the highlights to shading via "replace". This workaround is okay: however, I have to change all my highlights to shade regardless of color. Therefore, I can't change a specific color highlight to a shading.
Bonus question: Is there a way to select a specific highlighted color and change to shading? If it can't be done via VBA, is there a separate way to do it using the "replace" function?

2. If a word appears multiple time, highlight (or shading) the first instance differently than all subsequent instances.
For example, the word "home30" appears in my document 6 times. I want to highlight (or shading) the first instance as "green" and the subsequent instances as "orange". I would like to do this as part of my VBA code for all the items listed in my spreadsheet.

Thanks to anyone who is able to assist. I appreciate it very much. Happy holidays. The VBA code that I am using is below:

Code:

Sub Highlight()
Const strWorkbook As String = "C:\Users\me\Highlights.xlsx"
Const strSheet As String = "Sheet1"
Dim strFind As String
Dim oRng As Range
Dim i As Long
Dim Arr() As Variant

    Arr = xlFillArray(strWorkbook, strSheet)

    For i = 0 To UBound(Arr, 2)
        strFind = Arr(0, i)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            Do While .Execute(FindText:=strFind, _
                              MatchCase:=True, _
                              MatchWholeWord:=True, _
                              MatchWildcards:=False, _
                              Forward:=True, _
                              Wrap:=wdFindStop) = True
                oRng.HighlightColorIndex = wdRed
                oRng.Collapse wdCollapseEnd
            Loop
        End With
        DoEvents
    Next i
    Set oRng = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - Graham Mayor - Home Page - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strRange = strRange & "$]"    'Use this to work with a named worksheet
    'strRange = strRange & "]" 'Use this to work with a named range
    Set CN = CreateObject("ADODB.Connection")

    'Set HDR=NO for no header row
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function