Option Explicit

'http://www.cpearson.com/excel/colors.aspx -->
Private Declare Function ChooseColorDlg Lib "comdlg32.dll" Alias "ChooseColorA" ( _
    pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long

Private Const CC_RGBINIT = &H1&
Private Const CC_FULLOPEN = &H2&
Private Const CC_ANYCOLOR = &H100&

Private Type CHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private dwCustClrs(0 To 15) As Long

Public Function ChooseColorDialog(DefaultColor As Long) As Long
    Dim lpChoosecolor As CHOOSECOLOR
    With lpChoosecolor
        .lStructSize = Len(lpChoosecolor)
        .hwndOwner = GetActiveWindow
        .rgbResult = DefaultColor
        .lpCustColors = VarPtr(dwCustClrs(0))
        .flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_FULLOPEN
    End With
    If ChooseColorDlg(lpChoosecolor) Then
        ChooseColorDialog = lpChoosecolor.rgbResult
    Else
        ChooseColorDialog = -1
    End If
End Function
'<-- http://www.cpearson.com/excel/colors.aspx


Sub PhraseColor()
'---------------------------------------------------------------------------------------
' Procedure : PhraseColor
' Author    : Казанский, exceleved@yandex.ru
' Date      : 17.02.2015
' Purpose   : Ищет введенную фразу в выделенном диапазоне и выделяет цветом шрифта
'---------------------------------------------------------------------------------------

Static s$, col&
Dim c As Range, r As Range, a$, i&, lenS&
s = InputBox("Введите фразу для поиска", "Выделение цветом", s)
If s = "" Then Exit Sub
If col = 0 Then col = vbRed
col = ChooseColorDialog(col)
If col = -1 Then Exit Sub
Set r = Selection
Set c = r.Find(s, , xlValues, xlPart, MatchCase:=False)
If c Is Nothing Then Exit Sub
a = c.Address
lenS = Len(s)
Application.ScreenUpdating = False
Do
  i = 1
  Do
    i = InStr(i, c, s, vbTextCompare)
    If i = 0 Then Exit Do
    c.Characters(i, lenS).Font.Color = col
    i = i + lenS
  Loop
  Set c = r.FindNext(c)
Loop Until c.Address = a
Application.ScreenUpdating = True
End Sub