Excelで置換した文字に色をつけたい

質問

よろしくお願いします

Excelで、「対象シート」のB列を参照して、
「置換リスト」シートの一覧のC列の文字列をE列の文字列に置換するようにしています。
「対象シート」のA列には置換前のデータも入っているので、
「対象シート」のA列、B列それぞれの置換前、置換後の文字列に色をつけたいと思っています。
どの文字がどの文字に置換されたかを比較するためです。

置換後のB列のみ下記式で色をつけられたのですが、
該当文字が含まれる、セル内全部の文字の色が変わってしまいました。
該当文字だけの色を変えるにはどうすればよいでしょうか。
また、「置換リスト」シートのC列にある場は「対象シート」のA列の該当文字のみを赤くする方法も教えていただけないでしょうか。

Sub list置換_Click()
Dim list_sheet As Worksheet
Dim chg_sheet As Worksheet
'こっちは置換する元の文字と置換文字のリスト
Set list_sheet = Worksheets("置換リスト")
'こっちは一括置換したい対象のシート
Set chg_sheet = Worksheets("対象シート")
cnt = list_sheet.Range("c4").CurrentRegion.Rows.Count
For i = 4 To cnt
srcword = list_sheet.Cells(i, "C").Value
repword = list_sheet.Cells(i, "E").Value
With Application.ReplaceFormat.Font
.Subscript = False
.Color = 255
.TintAndShade = 0
End With
Columns("B:B").Replace What:=srcword, Replacement:=repword, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
Next i
End Sub

よろしくお願いいたします。

回答No.1

mitarashi

一括置換後、Findで該当セルを見つけて色を変更しても良いのですが、どうせFindを使うなら一括置換をやめて、一個ずつ検索して、置換後、文字の色を変更するコードです。検索、置換文字の１組のみのコードです。ご参考まで。
xl2000で試しています。

Sub test()
Dim c As Range, targetRange As Range
Dim firstAddress As String
Dim srcword As String, repword As String

srcword = "BC"
repword = "CB"
Application.ScreenUpdating = False
With Worksheets(1)
Set targetRange = .Range(.Range("a1"), .Range("a" & .Rows.Count).End(xlUp))
Set c = targetRange.Find(What:=srcword, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = Replace(c.Value, srcword, repword)
myChangeTextColor c, repword, vbRed
Set c = targetRange.FindNext(c)
If c Is Nothing Then Exit Do
Loop While c.Address <> firstAddress
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub myChangeTextColor(targetCell As Range, pattern As String, myColor As Long)
Dim startPos As Long

'Findと異なり、半角・全角、大文字・小文字を区別しますので、留意願います
startPos = InStr(targetCell.Value, pattern)
If startPos = 0 Then Exit Sub
targetCell.Characters(Start:=startPos, Length:=Len(pattern)).Font.Color = myColor
End Sub

お礼

ありがとうございます。
私が記載している情報が恐らく不足していて反応がありませんでしたが、
別の方法で解決いたしました。
記載していただいたコードも時間のある時に修正、確認してみたいと思います。
ひとまず解決しましたので、解決とします。