【VBA】Excelでセル内の一部分だけ書式ごと置換

最近知ったが、セル内に書式の異なる文字があった場合、

置換をすると、設定した書式が無くなる（一律、先頭文字の書式になる）。

（これは有名？？）

調べると、対策用のマクロをいろいろな人が作っているが、

興味があったので、自分も使いやすいようにサンプルコードを作成

今回のサンプルは、置換元と置換先の文字数が同じことが前提

置換元と置換先の文字数の異なる場合は、置換前後でオフセットをとらないとダメ

そこまでは未対応。

Sub test()
   
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim r  As Range
    Dim tmpR As Range
    Dim findR As Range
    Dim SearchStr As String
    Dim RepStr As String
    Dim i As Long
   
    ‘作業元ファイルとシートの指定
    Set Wb = ThisWorkbook
    Set Ws = Wb.Worksheets("Sheet1")
   
    ‘置換元と置換先の文字数が同じことが前提
    ‘置換元
    SearchStr = "CK040111"
    ‘置換先
    RepStr = "FF330112"
   
    ‘置換の検索範囲
    Set findR = Ws.Range("A1:F100")
   
    ‘書式等の保存先
    Set tmpR = Ws.Range("H1")
       
    For Each r In Ws.Range("A1:F100")
        ‘セルに、置換元の文字がある（Nothing(Null)ではない）時
        If Not r.Find(SearchStr) Is Nothing Then
            ‘セルの内容をコピー
            r.Copy tmpR
            ‘置換
            Call r.Replace(SearchStr, RepStr)
            ‘コピー元から１文字づつ書式等をコピー
            For i = 1 To tmpR.Characters.Count
                r.Characters(i, 1).Font.Color = tmpR.Characters(i, 1).Font.Color
                r.Characters(i, 1).Font.Name = tmpR.Characters(i, 1).Font.Name
                r.Characters(i, 1).Font.Size = tmpR.Characters(i, 1).Font.Size
                r.Characters(i, 1).Font.Strikethrough = tmpR.Characters(i, 1).Font.Strikethrough
                r.Characters(i, 1).Font.Superscript = tmpR.Characters(i, 1).Font.Superscript
                r.Characters(i, 1).Font.OutlineFont = tmpR.Characters(i, 1).Font.OutlineFont
            Next i
        End If
    Next r

    tmpR.Clear
   
End Sub