VBA to find cells with multiple words and change font color of one word to red-CodePudding

I need a VBA to find cells in Column H that have the word "only" and the word "Available" in the same cell and disregard all other occurences of "only". Then I want to turn the font color of "only" to red without changing the color of the other words in the cell.

Here is what I have so far. It finds all occurences of "only" but I don't know how to search for two words in the same cell.

Public Sub ChgTxtColor()
    Set myRange = Range("H1:H400")
    substr = "only"
    txtColor = 3
    
    For Each MyString In myRange
        lenstr = Len(MyString)
        lensubstr = Len(substr)
        For i = 1 To lenstr
            tempString = Mid(MyString, i, lensubstr)
            If tempString = substr Then
                MyString.Characters(Start:=i, 
                Length:=lensubstr).Font.ColorIndex = txtColor
            End If
        Next i
    Next MyString
End Sub

CodePudding user response：

Try this:

Public Sub ChgTxtColor()
    Dim myRange As Range, txtColor As Long, c As Range, v
    
    Set myRange = Range("H1:H400")
    txtColor = vbRed

    For Each c In myRange.Cells       'loop each cell in range
        v = c.Value
        If InStr(1, v, "only", vbTextCompare) > 0 Then
            If InStr(1, v, "available", vbTextCompare) > 0 Then
                HilightAllInCell c, "only", txtColor
            End If
        End If
    Next c
End Sub

'hilight all instances of `findText` in range `c` using text color `hiliteColor`
Sub HilightAllInCell(c As Range, findText As String, hiliteColor As Long)
    Dim v, pos As Long
    v = c.Value
    If Len(v) > 0 Then     'any text to check?
        pos = 0            'set start position
        Do
            pos = InStr(pos   1, v, findText, vbTextCompare) 'case-insensitive
            If pos > 0 Then  'found?
                'using Color instead of ColorIndex is more reproducible
                '  (since users can edit their color pallette)
                c.Characters(Start:=pos, Length:=Len(findText)).Font.Color = hiliteColor
            Else
                Exit Do    'not found, or no more matches
            End If
        Loop               'look again
    End If                 'anything to check
End Sub