VBA セル上で文字列の置換を取り消し線と置換後の新しい色で表現する

元ネタはこちら。おもしろそうなのでやってみた。
infoment.hatenablog.com

今回やりたいことは、文字列の一部を置換したときにその履歴そのものを取り消し線と色で表現したいというネタ。

つまり図示するとこういうこと。

参照元の記事では1回目は上手く行ってるんだけど、2回目に失敗している様子。

つまり、以下を成功させたい。

まずはデータ構造を考えてみる

複雑なプログラムを組む際に一番意識すべきはデータ構造。
やりたいこととデータ構造が綺麗にリンクしていれば、もう勝ったも同然。

今回のケースだと、文字ごとにステータスを持たせるのが良さげ。
以下のように一文字ずつ、取り消し線が引かれているか否か、追加された文字(つまり青字)か否かと、今回挿入する文字の挿入位置かどうかをTrue / Falseで管理する。

図では、Tと入っているところがTrueで、何もないところはFalse。

これはあくまでイメージ図なので、ここから実際のプログラムで使えるデータ構造に落とし込んでいく。
この表形式に思考を引っ張られると、じゃあ二次元配列で考えるか？とか間違った方向に進むので注意。

現実のデータ構造は階層を成していることが多いので、一旦ツリー型に落とし込んでみる。

次にこのツリーをどうやって表現するか。
文字のデータはクラスで表現しても良いけど、一文字ずつインスタンス化するのはちょっと大げさなので今回はユーザー定義型を採用することにする。さらにステータス部分は別のユーザー定義型にしてネストさせることにした。(今思えば各ステータスをテキストと並列にしても良かったかも。)
ユーザー定義型はコレクションに追加できないのでテキストのデータ集合としては自ずと配列に決まる。

構造部分だけをVBAコードに落としこむと、次のようになる。

Type State
    Strikethrough As Boolean
    InsertPoint As Boolean
    Replaced As Boolean
End Type

Type StatefulChar
    Text As String
    State As State
End Type

Private CellText() As StatefulChar

CellTextは動的配列で宣言し、実際にセルのテキストを格納する段でサイズを確定させる。

出力方法について考える

データの管理の他に、もうひとつ厄介な問題がある。それは文字の出力だ。
セル内のテキストに書式を持たそうとするのは面倒な処理が必要になる。

そこで今回は以前に作ったセル内の文字を簡単に色付けするためのクラスを少し改造して、取り消し線に対応させることにした。
thom.hateblo.jp

コード

ここからはコードの全体を紹介する。

まずはクラスモジュールを挿入し、名前をColorfulStringObjectとする。
コードは以下のとおり。

Private Type ColorText
    TextPart As String
    ColorPart As XlRgbColor
    Strikethrough As Boolean
End Type
Private colorTextArray() As ColorText

Private Sub Class_Initialize()
    ReDim colorTextArray(0)
End Sub

Sub AddText(txt As String, Optional col As XlRgbColor = rgbBlack, Optional strike_through As Boolean = False)
    colorTextArray(UBound(colorTextArray)).ColorPart = col
    colorTextArray(UBound(colorTextArray)).TextPart = txt
    colorTextArray(UBound(colorTextArray)).Strikethrough = strike_through
    ReDim Preserve colorTextArray(UBound(colorTextArray) + 1)
End Sub

Function GetText()
    Dim ret As String
    Dim i As Long
    For i = 0 To UBound(colorTextArray) - 1
        ret = ret & colorTextArray(i).TextPart
    Next
    GetText = ret
End Function

Sub WriteToCell(r As Range)
    r.Value = GetText
    Dim location As Long: location = 1
    For i = 0 To UBound(colorTextArray) - 1
        With r.Characters(location, Len(colorTextArray(i).TextPart)).Font
            .color = colorTextArray(i).ColorPart
            .Strikethrough = colorTextArray(i).Strikethrough
        End With
        location = location + Len(colorTextArray(i).TextPart)
    Next
End Sub

次に標準モジュールを挿入する。モジュール名は任意。
コードは以下のとおり。

Option Explicit
Type State
    Strikethrough As Boolean
    InsertPoint As Boolean
    Replaced As Boolean
End Type

Type StatefulChar
    Text As String
    State As State
End Type

Private CellText() As StatefulChar

Const OriginalWordColor As Long = 3289800
Const CorrectedWordColor As Long = 13120050

Sub CorrectWord( _
    target_range As Range, _
    original_word As String, _
    Optional corrected_word As String = "")
    
    Dim r As Range: Set r = Selection
    
    '以下でCellTextを実際の文字数よりも1つ多く確保しているのは、
    '空白セルを選んだときにインデックスエラーを回避するのと、
    'セルの内容が置換対象文字そのものだった場合に文字単位の
    'ヒットカウント(charPointer)が上手く機能しないトラブルを
    '回避するための苦肉の策。
    'なお、多めに確保したCellTextは中身が初期状態(vbNullString)
    'なので動作に悪影響を与えない。
    ReDim CellText(1 To Len(r.Value) + 1)
    
    '文字ごとにステータスを登録するフェーズ
    Dim i As Long
    For i = 1 To Len(r.Value)
        CellText(i).Text = Mid(r.Value, i, 1)
        CellText(i).State.Strikethrough = r.Characters(i, 1).Font.Strikethrough
        CellText(i).State.Replaced = r.Characters(i, 1).Font.color = CorrectedWordColor
    Next
    
    'original_wordの一致を一文字ずつ探すフェーズ
    Dim charPointer As Long: charPointer = 1
    Dim charLocationStore As Collection: Set charLocationStore = New Collection
    Dim n As Long: n = 1
    Do While n < UBound(CellText)
        If Not CellText(n).State.Strikethrough Then
            If Mid(original_word, charPointer, 1) = CellText(n).Text Then
                charPointer = charPointer + 1
                charLocationStore.Add n
            Else
                charPointer = 1
                Set charLocationStore = New Collection
            End If
            If charPointer > Len(original_word) Then
                Dim t
                For Each t In charLocationStore
                    CellText(t).State.Strikethrough = True
                Next
                CellText(n).State.InsertPoint = True
            End If
        End If
        n = n + 1
    Loop
    
    'セルに出力するためにColorfulStringObjectを構築するフェーズ
    Dim CSO As ColorfulStringObject: Set CSO = New ColorfulStringObject
    Dim j As Long
    For j = LBound(CellText) To UBound(CellText)
        Dim col As XlRgbColor
        If CellText(j).State.Strikethrough Then
            col = OriginalWordColor
        ElseIf CellText(j).State.Replaced Then
            col = CorrectedWordColor
        Else
            col = rgbBlack
        End If
        CSO.AddText CellText(j).Text, col, CellText(j).State.Strikethrough
        If CellText(j).State.InsertPoint Then
            CSO.AddText corrected_word, CorrectedWordColor, False
        End If
    Next
    
    '一気にセル書き出し
    CSO.WriteToCell target_range
End Sub

ちょっとこのプロシージャは長すぎるけど、まぁ今回は動いたところまでで満足したので良しとしよう。

最後に任意のモジュールに以下のコードを挿入する。

Sub CorrectTest()
    Call CorrectWord(Selection, "ばなな", "バナナ")
    Call CorrectWord(Selection, "おやつに入りません", "おやつに入ります")
End Sub

実行

「ばななはおやつに入りません。いいですか？ばななは、ですよ？」という文言が書かれたセルを選択した状態で、CorrectTestを実行すると、2回の編集が適用されて以下のように表示が変わる。

おまけ1 思考のプロセス

最初のデータ構造を考えるときに書いたメモ。赤字はブログ掲載したときに意味が分かるように追記したもの。

頭の中だけでは思考が破綻するので、データ構造で悩んだら適当に紙に書いてみたり、パワポのスマートアートでツリー作ってみたりと裏で色々ごにょごにょしてます。

おまけ2 破綻したアイデア

文字列をチャンクに分けて管理するということも考えた。

ただ結局チャンクを跨いで置換が発生するケースに対応できないと気付いて破綻。

しかしこの気付きのおかげで標準のReplace関数を捨てて自前で置換を実装することを決断。この判断は正しかったと思う。
コード中では自前で置換するための文字を消し込む位置の保持にcharLocationStoreコレクションを使っている。
一度消し込んだ文字にヒットさせないために、そうでない文字のロケーションだけがcharLocationStoreに貯めこまれる仕組み。

以上