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

'------------------------------------------------------------------------------
' 実行用マクロ
'------------------------------------------------------------------------------
Sub 選択セル範囲から任意の文字列を検索し色を付ける()
    
    ' 検索文字列
    Const L_WHAT As String = "市" ' 検索文字列はここで設定
    
    ' 選択しているオブジェクトがセルでなければ抜ける
    If TypeName(Application.Selection) <> "Range" Then
        MsgBox "対象のセル範囲を選択してください", vbInformation, "終了します"
        Exit Sub
    End If
    
    ' Rangeオブジェクトに選択セル範囲を設定
    Dim rngTarget As Range
    Set rngTarget = Application.Selection
    
    Dim strMessage As String
    '《セル内の任意の文字列に色を設定》
    ' ** 引数1：検索対象セル範囲
    ' ** 引数2：検索文字列
    ' ** 引数3：検索一致文字列に設定する色（省略可　既定：赤）
    ' ** 引数4：各セル内で検索を開始する文字の位置（省略可　既定：1）
    ' ** 引数5：各セル内で色を設定する回数（省略可　既定:0:制限なし）
    '   戻り値：成功：空の文字列　失敗：エラーメッセージ
    strMessage = setColorForCharacters(rngTarget, L_WHAT)

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

'------------------------------------------------------------------------------
' セル内の任意の文字列に色を設定
'------------------------------------------------------------------------------
'［引数］
'   rngTarget：検索対象セル範囲
'   What     ：検索文字列
'   Color    ：検索一致文字列に設定する色番号(既定:赤)
'   Start    ：各セル内で検索を開始する文字の位置（既定：1）
'   Times    ：各セル内で色を設定する回数(既定:0:制限なし)
'［戻り値］
'   成功：空の文字列　失敗：メッセージ
'［作成日］2023.05.31　［更新日］2025.03.14
' https://excel.syogyoumujou.com/vba/set_charactersfontcolor.html
'------------------------------------------------------------------------------
Function setColorForCharacters(ByRef rngTarget As Range, _
                               ByVal What As String, _
                      Optional ByVal Color As XlRgbColor = rgbRed, _
                      Optional ByVal Start As Long = 1, _
                      Optional ByVal Times As Long = 0) As String
                      
On Error GoTo LBL_ERROR

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

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

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

    '------------------------
    ' 対象セル範囲検索
    '------------------------
    ' 対象セル範囲から任意の文字列を含むセルを検索
    Set rngFind = rngTarget.Find(What, , xlValues, xlPart, xlByRows, , False, False)
    
    ' 検索に一致のセルがない場合
    If rngFind Is Nothing Then
        ' ※ 結合セルで検索に一致しないケースがあるため その対策処理
        Set rngFind = rngTarget.Find(What, , xlValues, xlPart, xlByColumns, , False, False)
        
        ' 検索に一致のセルがない場合はプロシージャを抜ける
        If rngFind Is Nothing Then
            setColorForCharacters = "対象の文字列はありません"
            Exit Function
        End If
    End If

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

    '------------------------
    ' セル内テキスト検索
    '------------------------
    Do
        lngStart = Start
        lngTimes = 0
        
        Do
            ' テキストを検索
            lngPosition = InStr(lngStart, rngFind.Value, What, vbTextCompare)

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

            rngFind.Characters(lngPosition, lngLen).Font.Color = Color
            lngTimes = lngTimes + 1

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

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

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

        ' セルアドレスが変数のアドレスと一致 またはセルを取得できない場合はループを抜ける
    Loop Until strAddress = rngFind.Address Or rngFind Is Nothing
    
    Exit Function

'------------------------
' エラー処理
'------------------------
LBL_ERROR:
    setColorForCharacters = "エラーが発生しました" & vbLf & _
                            "エラー番号:" & Err.Number & vbLf & _
                            Err.Description
    Err.Clear
End Function