特定の文字列のフォントカラーを赤色に変更する（VBA）

特定の文字列のフォントカラーを赤色に変更する

Option Explicit

Sub TextColorChange()

    '■概要
    '開いているシートの特定文字列の色を赤色に変更する
    '色を変更したいシートでマクロを実行する
    
    Call StartProcess
    
    '変数宣言
    Dim TargetSheet As Worksheet: Set TargetSheet = ActiveWorkbook.ActiveSheet
    Dim SerchText   As String: SerchText = ""
    Dim TextLength  As Integer: TextLength = 0
    Dim TextPoint   As Integer: TextPoint = 0
    Dim LastColumn  As Long: LastColumn = 0
    Dim LastRow     As Long: LastRow = 0
    Dim SerchObj    As Object: Set SerchObj = Nothing
    Dim TmpObj      As Object: Set TmpObj = Nothing
    
    '赤色に変更する文字列を取得するダイアログを表示
    SerchText = InputBox("Plz enter text to be change red", "InputBox", "")
    
    '文字列が未入力もしくはダイアログを閉じた場合は、実行終了
    If SerchText = "" Then
        Call EndProcess
        Exit Sub
    End If
    
    '文字列の長さを取得
    TextLength = Len(SerchText)
    
    '最終列、行を取得
    LastColumn = TargetSheet.Cells.SpecialCells(xlLastCell).Column
    LastRow = TargetSheet.Cells.SpecialCells(xlLastCell).Row
    
    '文字列を検索
    Set SerchObj = TargetSheet.Range(Cells(1, 1), Cells(LastRow, LastColumn)).Find(SerchText, LookAt:=xlPart)
    Set TmpObj = SerchObj '検索結果を一時保存
    
    '検索結果が存在しない場合は、実行終了
    If SerchObj Is Nothing Then
        Call EndProcess
        Exit Sub
    End If
    
    '最初の検索結果と同じになるまでループ
    Do
        '2つ目の文字列を検索
        Set SerchObj = TargetSheet.Range(Cells(1, 1), Cells(LastRow, LastColumn)).FindNext(SerchObj)
        
        '文字列の位置を取得
        TextPoint = InStr(SerchObj.Value, SerchText)
        
        '文字列を赤色に変更
        SerchObj.Characters(Start:=TextPoint, Length:=TextLength).Font.Color = RGB(255, 0, 0)
        
        '文字列の位置が取得できなくなるまでループ
        Do
            '2つ目の文字列の位置を取得
            TextPoint = InStr(TextPoint + 1, SerchObj.Value, SerchText)
            
            '文字列の位置を取得できた場合は実行
            If TextPoint <> 0 Then
                '文字列を赤色に変更
                SerchObj.Characters(Start:=TextPoint, Length:=TextLength).Font.Color = RGB(255, 0, 0)
            End If
            
        Loop While TextPoint <> 0
        
    Loop While TmpObj.Column <> SerchObj.Column Or TmpObj.Row <> SerchObj.Row
    
    Call EndProcess
    
End Sub

'開始処理
Function StartProcess()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
End Function

'終了処理
Function EndProcess()
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Function