リストと一致した文字を部分一致で検索し、ヒットした文字のみ色を変更したい

Question

実現したいこと

ここに実現したいことを箇条書きで書いてください。

• 「修正一覧」のA行に検索する文字のリストが作ってあります。
• 「修正一覧」に記載した文字を、「データ一覧」に対して部分一致で検索し、ヒットした文字のみを赤文字に置換したいです。

前提

ここに質問の内容を詳しく書いてください。

・検索した文字列を含むセルの文字がすべて赤文字になってしまいます。
セルの文字すべてではなく、一致した文字のみ赤文字にしたいです。
・下記コードを流用して使用したいです。大幅なコードの変更をせずに、セルの特定の文字のみを変更する、コードの修正案を教えていただけないでしょうか？

発生している問題・エラーメッセージ

「試したこと」に記載しました

該当のソースコード

Sub yuremark_backdata()
    Dim 修正一覧 As Range
    Dim データ範囲 As Range
    Dim i As Long
    Dim wb1 As Workbook
    Dim ExcelApp As New Application
    Dim ReadFolderFullPath  As String
    
        ReadFolderFullPath = "\\000.00.00.000\★活動テーマ\1件目\006_対策実施\表記ゆれ対\hyoukiyure_list.xlsx"
        ExcelApp.Visible = False
        ExcelApp.DisplayAlerts = False
        Set wb1 = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True)
    ' ワークシート「modify_ilist」を指定
    
    
    Set 修正一覧 = wb1.Worksheets("modify_ilist").Range("A1").CurrentRegion

    ' データ範囲はアクティブシートのUsedRangeを使用
    Set データ範囲 = activeSheet.UsedRange

    For i = 2 To 修正一覧.Rows.Count
        With Application.ReplaceFormat.Font.Color = 255
        End With

    データ範囲.Replace _
               What:=修正一覧.Cells(i, 1).Value, _
               ReplaceFormat:=True, _
               Replacement:="", _
               LookAt:=xlPart
    Next i

    wb1.Close SaveChanges:=False ' ワークブックを閉じる

    MsgBox "表記ゆれ候補を強調しました。"
End Sub

試したこと

    With Application.ReplaceFormat.Font.Color = 255
    End With
	
	↓
    With Application.ReplaceFormat.Characters.Font.Color = 255
    End With

にすると、「オブジェクトは、このプロパティまたはメソッドをサポートしていません」
と表示されます。
「Characters」	の使い方に問題があるところまでわかるのですが、どのように組み合わせたらよいかわかりません。

補足情報（FW/ツールのバージョンなど）

Answer 1

For文の中だけ。
・置換を検索に変更
・該当文字があれば文字位置を取得
・文字数分の色を変更

でどうでしょうか。

2023/10/24　13:14　
If (Not (findobj Is Nothing)) Then の次行、Elseがあったのを削除しました。
適当に書いていた時点で If (findobj Is Nothing) Then で書いていた名残です…

    For i = 2 To 修正一覧.Rows.Count
        Set findobj = データ範囲.Find(What:=修正一覧.Cells(i, 1).Value, LookAt:=xlPart)
        If (Not (findobj Is Nothing)) Then
            cStart = InStr(findobj, 修正一覧.Cells(i, 1).Value)
            cLen = Len(修正一覧.Cells(i, 1).Value)
            Cells(findobj.Cells.Row, findobj.Cells.Column).Characters(Start:=cStart, Length:=cLen).Font.Color = RGB(255, 0, 0)
        End If
    
    Next i

23/10/24 17:07 追記
丸ごと貼り付けておきます。
私の環境では動作しましたので、あとは動作環境でデバックしてもらうしかないかなと思います。

Sub yuremark_backdata_edit()

    Dim 修正一覧 As Range
    Dim データ範囲 As Range
    Dim i As Long
    Dim wb1 As Workbook
    Dim ExcelApp As New Application
    Dim ReadFolderFullPath  As String
    
        ReadFolderFullPath = "[filePath]\hyoukiyure_list.xlsx"
        ExcelApp.Visible = False
        ExcelApp.DisplayAlerts = False
        Set wb1 = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True)
    ' ワークシート「modify_ilist」を指定
    
    
    Set 修正一覧 = wb1.Worksheets("modify_ilist").Range("A1").CurrentRegion

    ' データ範囲はアクティブシートのUsedRangeを使用
    Set データ範囲 = ActiveSheet.UsedRange

    For i = 2 To 修正一覧.Rows.Count
        Set findobj = データ範囲.Find(What:=修正一覧.Cells(i, 1).Value, LookAt:=xlPart)
        If (Not (findobj Is Nothing)) Then
            cStart = InStr(findobj, 修正一覧.Cells(i, 1).Value)
            cLen = Len(修正一覧.Cells(i, 1).Value)
            Cells(findobj.Cells.Row, findobj.Cells.Column).Characters(Start:=cStart, Length:=cLen).Font.Color = RGB(255, 0, 0)
        End If
    
    Next i

    wb1.Close SaveChanges:=False ' ワークブックを閉じる

    MsgBox "表記ゆれ候補を強調しました。"
End Sub

Comments

[tera1325153]

お忙しい中回答いただけて、助かります！ありがとうございます！
理解不足ですみません。
「For」から「Next i」までカット＆ペーストしたのですが、「オブジェクト変数またはWith」ブロック変数が設定されていません」というエラーが出ました。
最初に下記コードを追加してみましたが、解決できていません。私は何か設定を間違えているのでしょうか
Dim cStart As Long
Dim cLen As Long
Dim findobj As Range

[mdj]

回答に一式を追加しましたので、ファイルパス部分のみ修正していただいて動作させてみてください。
そのうえでエラーが出るようでしたら、デバッグしてエラー箇所をご確認いただくことになるかなと思います。

[tera1325153]

お忙しい中ありがとうございます！！
少し修正すると、思い通りに動きました！！
ﾒﾓ↓

Sub yuremark()
Dim 修正一覧 As Range
Dim データ範囲 As Range
Dim i As Long
Dim k As Long
Dim wb1 As Workbook
Dim ExcelApp As New Application
Dim ReadFolderFullPath As String
Dim myStr As String
Dim findobj As Range
Dim myFirst As Range

ReadFolderFullPath = "[リンク]\hyoukiyure_list.xlsx"
ExcelApp.Visible = False
ExcelApp.DisplayAlerts = False
Set wb1 = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True)
Set 修正一覧 = wb1.Worksheets("modify_ilist").Range("A1").CurrentRegion
Set データ範囲 = activeSheet.UsedRange

For i = 2 To 修正一覧.Rows.Count
myStr = 修正一覧.Cells(i, 1)
Set findobj = データ範囲.Find(what:=修正一覧.Cells(i, 1).Value, lookat:=xlPart)

If Not findobj Is Nothing Then
Set myFirst = findobj
GoTo 処理
Do

Set findobj = データ範囲.FindNext(after:=findobj)
If findobj.Address = myFirst.Address Then Exit Do
GoTo 処理

処理:
For k = 1 To Len(findobj)
If Mid(findobj, k, Len(myStr)) = myStr Then
findobj.Characters(Start:=k, Length:=Len(myStr)).Font.ColorIndex = 3

End If
Next k
Loop
End If
Next i

wb1.Close SaveChanges:=False ' ワークブックを閉じる

MsgBox "表記ゆれ候補を強調しました。"
End Sub