Поиск подстроки в строке

Dim m() As String
If InStr(1, Cells(1, 2).Value, ",") > 0 Then
    m = Split(Replace(Cells(1, 2).Value, " ", ""), ",")
Else
    ReDim m(0): m(0) = Trim(Cells(1, 2).Value)
End If

Option Compare Text
Option Explicit
Sub QWERT()
Dim R, N, K
Dim m() As String
If InStr(1, Cells(1, 2).Value, ",") > 0 Then
    m = Split(Replace(Cells(1, 2).Value, " ", ""), ",")
Else
    ReDim m(0): m(0) = Trim(Cells(1, 2).Value)
End If
 
For R = 0 To UBound(m) 
N = 1
    If InStr(1, Cells(1, 1).Value, m(R)) > 0 Then
    K = InStr(N, Cells(1, 1).Value, m(R))
        Do
            ПОКРАСИТЬ K, Len(m(R))
            N = K + Len(m(R))
            K = InStr(N, Cells(1, 1).Value, m(R))
        Loop While K > 0
    End If
Next R
End Sub
Sub ПОКРАСИТЬ(ST, LN)
With Cells(1, 1).Characters(Start:=ST, Length:=LN).Font
.Color = RGB(0, 0, 255)
.Bold = True
End With
End Sub

Sub ПОКРАСИТЬ(ST, LN)
 LN = LN - 1
Do
    LN = LN + 1
Loop While VBA.Mid(Cells(1, 1).Value, ST + LN, 1) <> " "
 
With Cells(1, 1).Characters(Start:=ST, Length:=LN).Font
.Color = RGB(0, 0, 255)
.Bold = True
End With
End Sub