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

「replace.xlsm」をダウンロード

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

それだと、不便なことがあったので、文字列のフォントをきちんと保存して、置換後に元に戻すマクロを作成。

参考にしたのは、

・以前作ったイテレータもどき

・参考サイト

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

今の作りだと、置換前後の文字数は同じであることが前提の作りになっているので、次は置換前後の文字数が異なっても対応できる作りが必要だ。