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

'------------------------------------------------------------------------------
' 実行用マクロ
'------------------------------------------------------------------------------
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

'***************************************************************
'* セル内の任意の文字列に色を設定する
'*--------------------------------------------------------------
'* 概要     | 指定したセル範囲内の任意の文字列に色を設定する
'*          | 参考：https://excel.syogyoumujou.com/vba/set_charactersfontcolor.html
'* 引数     | 1) pRng   ：検索対象セル範囲（ByRef）
'*          | 2) pWhat  ：検索文字列
'*          | 3) pColor ：文字列に設定する色番号（既定：赤）
'*          | 4) pStart ：各セル内で検索を開始する文字位置（既定：1）
'*          | 5) pTimes ：各セル内で色を設定する回数（既定：0：制限なし）
'* 戻り値   | String型
'*          | 成功  ：""（空文字）
'*          | エラー：エラーメッセージ
'* 作成日   | 2023.05.31
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.06
'***************************************************************
Public Function setColorForCharacters(ByRef pRng As Range, _
                                      ByVal pWhat As String, _
                             Optional ByVal pColor As XlRgbColor = rgbRed, _
                             Optional ByVal pStart As Long = 1, _
                             Optional ByVal pTimes As Long = 0) As String
On Error GoTo LBL_ERROR

    '------------------------------
    ' 引数の検証
    '------------------------------
    ' セルオブジェクトが設定されていなければ抜ける
    If pRng Is Nothing Then
        setColorForCharacters = "セルオブジェクトが設定されていません"
        Exit Function
    End If

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

    '------------------------------
    ' 検索文字列を含むセルを検索
    '------------------------------
    Dim rngFnd As Range
    Set rngFnd = pRng.Find(What:=pWhat, _
                           LookIn:=xlValues, _
                           SearchOrder:=xlByColumns, _
                           LookAt:=xlPart, _
                           MatchCase:=False, _
                           MatchByte:=False)

    ' 検索に一致するセルがなければ抜ける
    If rngFnd Is Nothing 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   ' 検索文字列の長さ格納用

    lngLen = Len(pWhat)
    strAddress = rngFnd.Address

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

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

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

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

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

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

        ' FindNext が Nothing を返した場合はループを抜ける
        If rngFnd Is Nothing Then Exit Do

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

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    setColorForCharacters = "エラー番号：" & Err.Number & vbLf & Err.Description
End Function