【Excel VBA】セルの書式を変えずに置換（Replace)する方法

Excelの置換機能は、置換後に１文字目のフォントが文字列すべてに適用される仕様になっています。

そのため、セル内に異なるフォントや装飾が混在している場合に不便が生じるため、文字列のフォント書式を保持したまま置換を行って元に戻すVBAマクロを作成しました。

参考にした情報：

• 以前作成したイテレータもどき
• VBAのパフォーマンスに関する参考サイト

CFontCollector（クラスモジュール）

Option Explicit

Dim m_collection As VBA.Collection 'このオブジェクトがコレクターのキモ

Private Sub Class_Initialize()
    Set m_collection = New VBA.Collection
End Sub

Private Sub Class_Terminate()
    Set m_collection = Nothing
End Sub

Public Sub Add(ByVal Data As CFontData)
    Call m_collection.Add(Data)
End Sub

Public Sub Remove(ByVal index As Long)
    Call m_collection.Remove(index)
End Sub

Public Property Get Count() As Long
    Count = m_collection.Count
End Property

Public Property Get Item(ByVal index As Long) As CFontData
    Set Item = m_collection.Item(index)
End Property

Public Property Get FontDatas() As Collection
    Set FontDatas = m_collection
End Property

CFontData（クラスモジュール）

Option Explicit

Public start As Long
Public Length As Long
Public ColorIndex As Long
Public Bold As Boolean
Public Italic As Boolean
Public UnderLine As Variant
Public Strikethrough As Boolean
Public FontStyle As String
Public Name As String
Public Size As Variant

Private Sub Class_Initialize()
    Me.start = 0
    Me.Length = 0
    Me.ColorIndex = 0
    Me.Bold = False
    Me.Italic = False
    Me.Strikethrough = False
    Me.FontStyle = ""
    Me.Name = ""
    Me.UnderLine = Empty
    Me.Size = Empty
End Sub

Private Sub Class_Terminate()

End Sub

Public Sub Copy(ByRef F As Font)
    With F
        Me.Name = .Name
        Me.ColorIndex = .ColorIndex
        Me.FontStyle = .FontStyle
        Me.UnderLine = .UnderLine
        Me.Italic = .Italic
        Me.Strikethrough = .Strikethrough
        Me.Size = .Size
    End With
End Sub

Public Sub SetFont(ByRef F As Font)
    With F
        .Name = Me.Name
        .ColorIndex = Me.ColorIndex
        .FontStyle = Me.FontStyle
        .UnderLine = Me.UnderLine
        .Italic = Me.Italic
        .Strikethrough = Me.Strikethrough
        .Size = Me.Size
    End With
End Sub

Public Function Diff(ByRef F As Font) As Boolean
    Diff = False
    
    'フォントに変化があった場合
    If ((Me.FontStyle <> F.FontStyle) Or _
        (Me.ColorIndex <> F.ColorIndex) Or _
        (Me.UnderLine <> F.UnderLine) Or _
        (Me.Italic <> F.Italic) Or _
        (Me.Strikethrough <> F.Strikethrough) Or _
        (Me.Size <> F.Size) Or _
        (Me.Bold <> F.Bold) Or _
        (Me.Name <> F.Name)) Then
        Diff = True
    End If
End Function

Sheet1 または標準モジュール

Option Explicit

Sub test()
    Call FullReplace("B3", "test", "abcd")
End Sub

'フォントも含めた置換を行う（置換前後の文字数が同一であることが条件）
Sub FullReplace(ByVal RangeArea As String, ByVal What As String, ByVal Replacement As String)
    Dim FontCollector As CFontCollector
    Set FontCollector = New CFontCollector
    
    Dim MyRange As Range
    Set MyRange = ActiveSheet.Range(RangeArea)
    
    Dim i, Length As Long
    Dim Data As CFontData
    Dim F As Font

    Length = Len(MyRange.Value)
    ' セルの文字数だけループする
    For i = 1 To Length
        Set F = MyRange.Characters(i, 1).Font
        
        If i = 1 Then '初回、フォントデータコピー
            Set Data = New CFontData
            Data.start = 1
            Call Data.Copy(F)
        ElseIf i = Length Then '最後 フォント情報の収集完了、コレクターに格納
            Data.Length = i - Data.start + 1
            Call FontCollector.Add(Data)
            Set Data = Nothing
        Else
            '保存していたフォントと異なる（変化が出た）場合、その位置から再保存
            If Data.Diff(F) = True Then
                
                'ここまででフォント情報の収集が完了するので、コレクターに格納
                Data.Length = i - Data.start
                Call FontCollector.Add(Data)
                
                '次に、新規フォント情報を保存
                Set Data = Nothing
                Set Data = New CFontData
                Data.start = i
                Call Data.Copy(F)
            End If
        End If
    Next
    
    '置換
    Call MyRange.Replace(What, Replacement)
    
    'フォントの復元
    For Each Data In FontCollector.FontDatas
        Set F = MyRange.Characters(Data.start, Data.Length).Font
        Call Data.SetFont(F)
        Set Data = Nothing
    Next Data
    Set FontCollector = Nothing
   
End Sub

現在の実装では、置換前後の文字数が同一であることが前提の作りになっています。文字数が異なっても対応できるようにするには、さらに拡張が必要です。