Highlighting selected words in a column.

[ylafont]

I have the HighlighWords Macro below, that i used to search through a column and highlight all words found on "sheet1 column A", The script work normally if run from the macros window, I was trying to incorporate this code into a button on the ribbon bar to have it available at all times for different worksheets and i am running into a few hiccups and get and Run-time error 9 subscript out range error.

A little background
The script work normally if run from the macros window
I have modified the Excel Ribbon to display a custom tab which is stores in another xlsm file and launch at startup.
the file being modifide in another file

Sub HighlightWords()
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim sourceCell As Range
    Dim destinationCell As Range
    Dim lastRowSource As Long
    Dim lastRowDestination As Long
    Dim text As String
    Dim startPos As Integer
    Dim endPos As Integer
    
    ' Set references to source and destination sheets
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set destinationSheet = ThisWorkbook.Sheets("SaveOn-MSTeams-0001")
    
    ' Find the last row with data in column A of Sheet1
    lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' Find the last row with data in column D of SaveOn-MSTeams-0001
    lastRowDestination = destinationSheet.Cells(destinationSheet.Rows.Count, "D").End(xlUp).Row
    
    ' Loop through each cell in column A of Sheet1
    For Each sourceCell In sourceSheet.Range("A1:A" & lastRowSource)
        text = sourceCell.Value
        
        ' Loop through each cell in column D of SaveOn-MSTeams-0001
        For Each destinationCell In destinationSheet.Range("D1:D" & lastRowDestination)
            ' Check if the destination cell contains the text from the source cell (wildcard matching)
            startPos = InStr(1, LCase(destinationCell.Value), LCase(text), vbTextCompare)
            If startPos > 0 Then
                endPos = startPos + Len(text) - 1
                ' Highlight the matching phrase in the destination cell
                destinationCell.Characters(startPos, Len(text)).Font.Color = RGB(255, 0, 0) ' Red color
                destinationCell.Characters(startPos, Len(text)).Font.Bold = True ' Bold the selection
            End If
        Next destinationCell
    Next sourceCell
End Sub

i have modified the code to work on the active worksheet an it runs but it highlights the entire cell. not just the words found in sheet 1 column A

Sub Macro8(control As IRibbonControl)
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim sourceCell As Range
    Dim destinationCell As Range
    Dim lastRowSource As Long
    Dim lastRowDestination As Long
    Dim text As String
    Dim startPos As Integer
    Dim endPos As Integer
    
    Set destinationSheet = ActiveSheet
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
        
    lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    lastRowDestination = destinationSheet.Cells(destinationSheet.Rows.Count, "D").End(xlUp).Row
    
    MsgBox "The name of the active sheet is " & ActiveSheet.Name
    

    For Each sourceCell In sourceSheet.Range("A1:A" & lastRowSource)
        text = sourceCell.Value
        For Each destinationCell In destinationSheet.Range("D1:D" & lastRowDestination)

            startPos = InStr(1, LCase(destinationCell.Value), LCase(text), vbTextCompare)
            If startPos > 0 Then
                endPos = startPos + Len(text) - 1

                destinationCell.Characters(startPos, Len(text)).Font.Color = RGB(255, 0, 0) ' Red color
                destinationCell.Characters(startPos, Len(text)).Font.Bold = True ' Bold the selection
            End If
        Next destinationCell
    Next sourceCell

Long term here to make it as dynamic as possible without hardcoding the source and destinationon cells. any input is great appreciated, thank you in advance.

 

[Akuini]

Set sourceSheet = ThisWorkbook.Sheets("Sheet1")

Shouldn't ThisWorkbook change to ActiveWorkbook ?

 

[ylafont]

Jesus, that was a hard lesson. i have only been looking and trying different things for 2 days.

Thank you Akuini, very much appreciated.

 

[Akuini]

Glad it work.

Long term here to make it as dynamic as possible without hardcoding the source and destinationon cells. any input is great appreciated, thank you in advance.

Just an idea, but maybe you could use an input box to define the source and destination cells. Essentially, 2 inputbox would pop up, asking you to select the source sheet and destination cells. However, I haven't thought it through completely. I could probably try it tomorrow, if you're interested.
I use this technique to select a range via inputbox in one of my macro. You can check it here.

 

[ylafont]

I was thinking along the same lines, not sure what the best approach would be since i am not a programmer (but can manage a bit). Anything I do takes me time and effort, modifying the tab is a great method of keeping things organized and being able to share macros with my group.

1 - Keep as is and present the user with the dialog box as you suggest, (source and Destination and colors to use)

2 - Select the column or cells and then run the macro, Present a box where the user enters all words to be highlighted and select the color. this way multiple colors can be used for multiple different words.

I will take any advice! I will look through your example.

 

[ylafont]

Although it still can be improved further, I wanted to pass what I ultimately used. Hopefully, it can help someone in the future.

The form reads the first two columns of a sheet Column A - is the words the search for. Column b are the RGB color to use for the selection. This will be applied to the currently selection.

Private Sub CommandButton2_Click()
    Unload UserForm1
    End
End Sub

Public Sub OKButton_Click()
    
    Dim sourceSheet As Worksheet
    Dim text As String
    Dim destinationCell As Range
    Dim lastRowSource As Long
    Dim sourceCell As Range
    Dim selectedRange As Range
    Dim startPos As Integer
    Dim endPos As Integer
    Dim colorCell As Range                       ' New variable to hold color information
    
    Set selectedRange = Selection
    'MsgBox "Selected Range: " & selectedRange.Address
    
    'Set sourceSheet = ActiveWorkbook.Sheets(frm.ComboBox1.Value)            ' Set source sheet based on the selection in the ComboBox
    Set sourceSheet = ActiveWorkbook.Sheets(ComboBox1.Value)
    'MsgBox sourceSheet
    
    ' Iterate through each cell in the selected range
    For Each destinationCell In selectedRange
        text = destinationCell.Value
        lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
        For Each sourceCell In sourceSheet.Range("A1:A" & lastRowSource)
            startPos = InStr(1, LCase(text), LCase(sourceCell.Value), vbTextCompare)
             If startPos > 0 Then
                endPos = startPos + Len(sourceCell.Value) - 1
                
                Set colorCell = sourceCell.Offset(0, 1) ' Offset to get the corresponding color from column B
                
                Dim rgbString As String
                Dim rgbArray() As String
                rgbString = colorCell.Value
                rgbArray = Split(rgbString, ", ")
                Dim red As Integer
                Dim green As Integer
                Dim blue As Integer
                red = CInt(rgbArray(0))
                green = CInt(rgbArray(1))
                blue = CInt(rgbArray(2))
                
                'MsgBox colorCell
                destinationCell.Characters(startPos, Len(sourceCell.Value)).Font.Color = RGB(red, green, blue)  ' Red color
                                
                If CheckBox1.Value = True Then
                    destinationCell.Characters(startPos, Len(sourceCell.Value)).Font.Bold = True  ' Bold the selection
                End If
                
                If CheckBox2 = True Then
                    destinationCell.Characters(startPos, Len(sourceCell.Value)).Font.Italic = True  ' Italisize the selection
                End If
                
                If CheckBox3 = True Then
                    destinationCell.Characters(startPos, Len(sourceCell.Value)).Font.Underline = True  ' Underline the selection
                End If
                
            End If
        Next sourceCell
    Next destinationCell
    
End Sub

Private Sub UserForm_Initialize()

    'MsgBox "The Form is being initialized"
    
    For Each ws In ActiveWorkbook.Sheets                            ' Loop through each worksheet in the active workbook
        ComboBox1.AddItem ws.Name                               ' Add tab names to the ComboBox
    Next ws
    
    If ActiveWorkbook.Worksheets.Count > 0 Then                     ' Set the default selected choice to the first sheet
        ComboBox1.Value = ActiveWorkbook.Sheets(1).Name
    End If
   
End Sub

 

[Akuini]

That's great, thank you for sharing this.