トップ　>　汎用コード　>　セル内の任意の文字列に色を設定

'------------------------------------------------------------------------------
' 実行マクロ
'------------------------------------------------------------------------------
Sub ExampleOfUse_SetColorForCharacters()
    
    '検索文字列
    Const C_WHAT As String = "市" '検索文字列はここで設定
    
    '選択しているオブジェクトがセルでなければ抜ける
    If TypeName(Selection) <> "Range" Then
        MsgBox "対象のセル範囲を選択してください", vbInformation, "終了します"
        Exit Sub
    End If
    
    'Rangeオブジェクトに選択セル範囲を設定
    Dim rngTarget As Range
    Set rngTarget = Selection
    
    'プロシージャの実行
    Dim strMessage As String
    strMessage = SetColorForCharacters(rngTarget, C_WHAT)

    '結果メッセージ
    If strMessage = "" Then
        MsgBox "実行完了しました。", vbInformation
    Else
        MsgBox strMessage, vbExclamation
    End If
End Sub

'------------------------------------------------------------------------------
' セル内の任意の文字列に色を設定するプロシージャ
'------------------------------------------------------------------------------
'［引数］
'   Target：検索対象セル範囲
'   What  ：検索文字列
'   Color ：文字列に設定する色番号(既定:赤)
'   Start ：各セル内で検索を開始する文字の位置（既定：1）
'   Times ：各セル内で色を設定する回数(既定:0:制限なし)
'［戻り値］
'   成功：空の文字列　失敗：メッセージ
'［作成日］2023/05/31　［更新日］2023/06/09
'https://excel.syogyoumujou.com/vba/set_charactersfontcolor.html
'------------------------------------------------------------------------------
Function SetColorForCharacters(ByRef Target As Range, _
                               ByVal What As String, _
                               Optional Color As XlRgbColor = rgbRed, _
                               Optional Start As Long = 1, _
                               Optional Times As Long = 0) As String
    'Target にセルが設定されていなければ抜ける
    If Target Is Nothing Then
        SetColorForCharacters = "セルオブジェクトが設定されていません"
        Exit Function
    End If

    '検索文字列が空の場合は抜ける
    If What = "" Then
        SetColorForCharacters = "検索文字列がありません"
        Exit Function
    End If

    Dim strAddress As String 'セルアドレス格納用
    Dim lngStart   As Long   '検索スタート位置設定用
    Dim lngPos     As Long   'テキスト内の検索文字列位置格納用
    Dim lngTimes   As Long   'テキスト内での色設定回数 (セル毎)
    Dim lngLen     As Long   '検索文字列の長さ格納用
    Dim rngFnd     As Range  '検索用

    '検索文字列の文字数取得
    lngLen = Len(What)

    '対象セル範囲から検索文字列を含むセルを検索
    Set rngFnd = Target.Find(What:=What, _
                             LookIn:=xlValues, _
                             SearchOrder:=xlByRows, _
                             LookAt:=xlPart, _
                             MatchCase:=False, _
                             MatchByte:=False)
    '検索に一致するセルがなければ抜ける
    If rngFnd Is Nothing Then
        SetColorForCharacters = "対象の文字列はありません"
        Exit Function
    End If

    '最初に一致したセルのアドレスを取得
    strAddress = rngFnd.Address

    On Error GoTo ERROR_HANDLER

    Do
        'テキスト内の検索文字列に色を設定
        lngStart = Start
        lngTimes = 0
        Do
            'テキストを検索
            lngPos = InStr(lngStart, rngFnd.Value, What, vbTextCompare)

            'テキスト内に検索文字列が見つからなかったら抜ける
            If lngPos = 0 Then Exit Do

            rngFnd.Characters(lngPos, lngLen).Font.Color = Color
            lngTimes = lngTimes + 1

            '指定した設定回数に到達したら抜ける
            If lngTimes = Times Then Exit Do

            '検索スタート位置を再設定
            lngStart = lngPos + lngLen
        Loop

        '対象セル範囲内で次の検索一致セルを検索
        Set rngFnd = Target.FindNext(rngFnd)

        'セルのアドレスが変数のアドレスと一致したらループを抜ける
    Loop Until strAddress = rngFnd.Address

    On Error GoTo 0
    
    Exit Function
ERROR_HANDLER:
    SetColorForCharacters = "エラーが発生しました" & vbLf & _
                            "エラー番号:" & Err.Number & vbLf & _
                            Err.Description
    Err.Clear
End Function