VBAで置換→置換した箇所の色変更を行いたい

実現したいこと

VBAで、指定文字を含むセルを検索し、ヒットした場合は置換して、置換した箇所を赤くするマクロを作成しています。
細かい仕様は下記になります。
・ユーザーからの入力として、検索文字と置換文字をInputBoxで受け取る。
・指定文字を含むセルを検索し、ヒットした場合は置換して、置換した箇所を赤くする。
・置換する際は、一括置換ではなく都度確認メッセージを出す（ctrl+zが使えないための安全策）。
・確認メッセージはvbYesNoCancelで実装。
┗「はい」→置換&色変換
┗「いいえ」→1つスキップ
┗「キャンセル」→マクロを終了
・同一セル内に検索文字（置換対象）が複数ある場合、個別に確認メッセージを出し、置換するかどうかを選択できるようにする。

動作例）　※[]←で囲まれている箇所が赤字
input→検索文字：aaa, 置換文字：zzz
①「はい」を選択
セル値：aaa,bbb,ccc　期待結果：[zzz],bbb,ccc
②全て「はい」を選択
セル値：aaa,bbb,aaa,ccc　期待結果：[zzz],bbb,[zzz],ccc
③全て「はい」を選択
セル値：bbb,aaa,ccc,aaa　期待結果：bbb,[zzz],ccc,[zzz]
④1回目は「いいえ」、2回目で「はい」を選択
セル値：aaa,bbb,aaa,ccc　期待結果：aaa,bbb,[zzz],ccc
⑤全て「いいえ」を選択
セル値：aaa,bbb,aaa,ccc　期待結果：aaa,bbb,aaa,ccc（置換なし）

発生している問題・分からないこと

セル内に複数検索文字が出現する場合の置換や、検索などの実装は想定通りの結果になっていますが、色変換の部分がうまくいきません。
具体的には、動作例②、③のパターンで、2回目の置換時の後の色変換がおかしくなっています。
ソースを見るとわかる通り、loopで「置換→色変換」を回しているのですが、デバッグをしてみると、2回目の置換時に、なぜかセル内の文字の色が変更されているみたいです。
input→検索文字：aaa, 置換文字：zzz
動作例②　セル値：aaa,bbb,aaa,ccc　期待結果：[zzz],bbb,[zzz],ccc　実際の結果：[zzz,bbb,zzz,ccc]
動作例③　セル値：bbb,aaa,ccc,aaa　期待結果：bbb,[zzz],ccc,[zzz]　実際の結果：bbb,zzz,ccc,[zzz]

こちら、置換時になぜセル内の文字の色が勝手に変更されてしまうのでしょうか？
解決策を提示していただけると助かります。
（chatGPTにも聞いてみましたが、解決しませんでした。）
また、VBAは職場を本格的に学び始めたのが去年の冬ごろからなので、書き方がかなり冗長かもしれません。
その点についてもご指摘いただきたいです。
よろしくお願いいたします。

該当のソースコード

' 置換しなかったセル
Dim noReplaceCell As Range

' 指定文字を置換して指定箇所に色を付ける
Sub ReplaceAndColoraaa()
    Dim searchWord As String
    Dim replaceWord As String
    Dim rStart As Range
    Dim rNext As Range
    Set noReplaceCell = Nothing

    ' 検索文字
    ' searchWord = InputBox("検索文字")
    searchWord = "aaa"
    ' 置換文字
    ' replaceWord = InputBox("置換文字")
    replaceWord = "zzz"


    ' 検索してrangeオブジェクトを取得
    Set rStart = ActiveSheet.Cells.Find(searchWord, lookat:=xlPart, MatchCase:=False, MatchByte:=False)

    ' セルが見つからなかった場合は終了
    If rStart Is Nothing Then
        MsgBox "見つかりません"
        Exit Sub
    End If

    ' 次の検索の初期Rangeオブジェクトに設定
    Set rNext = rStart

    ' 色付けマクロを呼び出し
    Call replaceAndColorSet(rStart, searchWord, replaceWord)
    ' //次を検索
    Do
        Set rNext = Cells.FindNext(After:=rNext)
        ' 検索不一致時はループを抜ける
        If rNext Is Nothing Then
            MsgBox "最後まで検索しました"
            Exit Do
        End If

        ' 最初に検索されたセルが再検索された場合もループを抜ける
        If Not noReplaceCell Is Nothing Then
            If rNext.Address = noReplaceCell.Address Then
                MsgBox "最後まで検索しました"
                Exit Do
            End If
        End If

        ' 色付けマクロを呼び出し
        Call replaceAndColorSet(rNext, searchWord, replaceWord)
    Loop
End Sub


' セル内の指定文字を置換して色付け （Rangeオブジェクト,検索文字,置換文字,色付け文字）
Sub replaceAndColorSet(rStart As Range, searchWord As String, replaceWord As String)
    Dim iStart As Integer
    Dim wordStartPosition As Integer
    Dim wordEndPosition As Integer
    Dim cnt As Integer: cnt = 1


    ' セル内の検索開始位置
    iStart = 1
    ' 変更色
    colorRGB = RGB(255, 0, 0)
    ' 検索文字の終了位置（検索文字数）
    wordEndPosition = Len(searchWord)


    ' 文字色変更
    ' 同一セル内で検索文字が複数回出現する可能性を考慮して繰り返す
    Do
        ' セル内の検索文字の出現位置を取得
        wordStartPosition = InStr(iStart, rStart, searchWord)
        ' 見つからなかったら抜ける
        If wordStartPosition = 0 Then
            Exit Do
        End If

        ' 置換確認 (Noを選択した場合は1つスキップ)
        Range(rStart.Address).Select
        Range(rStart.Address).Characters(wordStartPosition, wordEndPosition).Font.Underline = True
        response = MsgBox(cnt & "つ目の文字を置換しますか？", vbYesNoCancel + vbQuestion, "置換の確認")
        Range(rStart.Address).Characters(wordStartPosition, wordEndPosition).Font.Underline = False

        ' Yesが選択された場合置換して色を付ける
        If response = vbYes Then
            rStart.Value = WorksheetFunction.Replace(rStart, wordStartPosition, wordEndPosition, replaceWord)
            ActiveCell.Characters(Start:=wordStartPosition, length:=wordEndPosition).Font.Color = colorRGB

            ' Noが選択された場合はそのセルをキープ
        ElseIf response = vbNo And noReplaceCell Is Nothing Then
            Set noReplaceCell = rStart

            ' キャンセルが選択された場合はマクロを終了
        ElseIf response = vbCancel Then
            End
        End If
        
        ' 次の検索開始位置を今の検索の終了位置にずらす
        iStart = wordStartPosition + wordEndPosition
        cnt = cnt + 1
    Loop
End Sub

試したこと・調べたこと

teratailやGoogle等で検索した
ソースコードを自分なりに変更した
知人に聞いた
その他

上記の詳細・結果

結果は変わりませんでした。

補足

特になし

YellowGreen

2024/04/17 20:10 編集

現象に関係あるかどうかわかりませんが、コードを見た時の素朴な疑問です。文字列の置換後もwordEndPosition（長さなのに位置を表す変数名も不思議）はそのままですが、検索文字列と置換文字列は必ず同じ長さなのですか？ wordEndPositionという変数名を置換前: searchWordLength 置換後: replaceWordLength に読み替えると私の疑問の意味がわかりやすくなると思います。

ru-ru-ru

2024/04/18 02:32

確かにおっしゃる通りで、検索文字と置換文字の文字数が異なる場合を考慮できていませんでした。 wordEndPositionをsearchWordLengthとreplaceWordLengthに分け、置換後はreplaceWordLengthで処理をするようにした結果、文字数が異なっていても期待通りの動きをするようになりました。ありがとうございました。

行動規範の内容に同意します

回答1件

ベストアンサー

原因は下記の rStart.Value に代入している部分です。
Valueに代入すると先頭文字の書式が全体に反映されます。

vba
1        ' Yesが選択された場合置換して色を付ける
2        If response = vbYes Then
3            rStart.Value = WorksheetFunction.Replace(rStart, wordStartPosition, wordEndPosition, replaceWord)
4            ActiveCell.Characters(Start:=wordStartPosition, length:=wordEndPosition).Font.Color = colorRGB

CharactersのTextプロパティに置換文字を代入するようにすればいいでしょう。

vba
1        ' Yesが選択された場合置換して色を付ける
2        If response = vbYes Then
3            ActiveCell.Characters(Start:=wordStartPosition, Length:=wordEndPosition).Text = replaceWord
4            ActiveCell.Characters(Start:=wordStartPosition, length:=wordEndPosition).Font.Color = colorRGB