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

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

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

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

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

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

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

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

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

Type State
    Strikethrough AsBoolean
    InsertPoint AsBoolean
    Replaced AsBooleanEndTypeType StatefulChar
    Text AsString
    State As State
EndTypePrivateCellText()As StatefulChar

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

出力方法について考える

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

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

コード

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

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

PrivateType ColorText
    TextPart AsString
    ColorPart As XlRgbColor
    Strikethrough AsBooleanEndTypePrivate colorTextArray()As ColorText

PrivateSub Class_Initialize()ReDim colorTextArray(0)EndSubSub AddText(txt AsString,Optional col As XlRgbColor = rgbBlack,Optional strike_through AsBoolean=False)
    colorTextArray(UBound(colorTextArray)).ColorPart = col
    colorTextArray(UBound(colorTextArray)).TextPart = txt
    colorTextArray(UBound(colorTextArray)).Strikethrough = strike_through
    ReDimPreserve colorTextArray(UBound(colorTextArray)+1)EndSubFunctionGetText()Dim ret AsStringDim i AsLongFor i =0ToUBound(colorTextArray)-1
        ret = ret & colorTextArray(i).TextPart
    NextGetText= ret
EndFunctionSub WriteToCell(r As Range)
    r.Value=GetTextDim location AsLong: location =1For i =0ToUBound(colorTextArray)-1With r.Characters(location,Len(colorTextArray(i).TextPart)).Font
            .color = colorTextArray(i).ColorPart
            .Strikethrough = colorTextArray(i).Strikethrough
        EndWith
        location = location +Len(colorTextArray(i).TextPart)NextEndSub

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

OptionExplicitType State
    Strikethrough AsBoolean
    InsertPoint AsBoolean
    Replaced AsBooleanEndTypeType StatefulChar
    Text AsString
    State As State
EndTypePrivateCellText()As StatefulChar

Const OriginalWordColor AsLong=3289800Const CorrectedWordColor AsLong=13120050Sub CorrectWord( _
    target_range As Range, _
    original_word AsString, _Optional corrected_word AsString="")Dim r As Range: Set r = Selection
    
   '以下でCellTextを実際の文字数よりも1つ多く確保しているのは、'空白セルを選んだときにインデックスエラーを回避するのと、'セルの内容が置換対象文字そのものだった場合に文字単位の'ヒットカウント(charPointer)が上手く機能しないトラブルを'回避するための苦肉の策。'なお、多めに確保したCellTextは中身が初期状態(vbNullString)'なので動作に悪影響を与えない。ReDimCellText(1ToLen(r.Value)+1)'文字ごとにステータスを登録するフェーズDim i AsLongFor i =1ToLen(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 AsLong: charPointer =1Dim charLocationStore As Collection: Set charLocationStore =New Collection
    Dim n AsLong: n =1DoWhile n <UBound(CellText)IfNotCellText(n).State.Strikethrough ThenIfMid(original_word, charPointer,1)=CellText(n).Text Then
                charPointer = charPointer +1
                charLocationStore.Add n
            Else
                charPointer =1Set charLocationStore =New Collection
            EndIfIf charPointer >Len(original_word)ThenDim t
                ForEach t In charLocationStore
                    CellText(t).State.Strikethrough =TrueNextCellText(n).State.InsertPoint =TrueEndIfEndIf
        n = n +1Loop'セルに出力するためにColorfulStringObjectを構築するフェーズDim CSO As ColorfulStringObject: Set CSO =New ColorfulStringObject
    Dim j AsLongFor j =LBound(CellText)ToUBound(CellText)Dim col As XlRgbColor
        IfCellText(j).State.Strikethrough Then
            col = OriginalWordColor
        ElseIfCellText(j).State.Replaced Then
            col = CorrectedWordColor
        Else
            col = rgbBlack
        EndIf
        CSO.AddText CellText(j).Text, col,CellText(j).State.Strikethrough
        IfCellText(j).State.InsertPoint Then
            CSO.AddText corrected_word, CorrectedWordColor,FalseEndIfNext'一気にセル書き出し
    CSO.WriteToCell target_range
EndSub

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

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

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

実行

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

おまけ1 思考のプロセス

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

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

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

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

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

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

以上