文字の修正（失敗談）

本来 Word などで作成すべき文書が、なぜか Excel で作成されていることがあります。同書類を校閲する機会が何度もあって、↓ のような感じで修正するのですが、これがかなり面倒くさい。

Word なら、簡単に履歴が残せるのに。ということで、随分前になりますが、履歴付きで簡単に修正できるマクロの作成を試みたことがあります。こんな感じです。

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 errMsg(1) As String
        errMsg(0) = "修正対象となる文字列が、指定したセルに存在しません。"
        errMsg(1) = "修正前後の文字が同じです。"
    
    Dim errIndex As Integer
        If InStr(1, target_range.Value, original_word) = 0 Then
            errIndex = 0
            GoTo er1:
        ElseIf original_word = corrected_word Then
            errIndex = 1
            GoTo er1:
        End If
    
    ' 修正前文字列の直後に、修正後文字列を追加する。        
        target_range.Value = Replace(target_range.Value, _
                                     original_word, _
                                     original_word & corrected_word)
        
    Dim WordLength As Long
        WordLength = Len(original_word)
    
    ' 修正前文字列の開始位置を、修正前文字列の数だけ取得する。
    Dim WordLocate() As Long
    Dim i As Long
        i = 0
        Do
            ReDim Preserve WordLocate(i)
            Select Case i
                Case 0
                    WordLocate(i) = InStr(1, target_range.Value, original_word)
                Case Else
                    WordLocate(i) = InStr(WordLocate(i - 1) + Len(original_word) + 1, _
                                          target_range.Value, original_word)
            End Select
        
        ' 該当文字が存在しない場合、開始位置は「０」になる ⇒ ループ終了。        
            If WordLocate(i) = 0 Then Exit Do
            i = i + 1
        Loop
    
    ' 配列の数だけ、修正前文字列について以下の処理を行う。
    ' ① 修正線追加
    ' ② 赤文字に変更    
        For i = 0 To UBound(WordLocate) - 1
            With target_range.Characters(Start:=WordLocate(i), Length:=WordLength).Font
                .Strikethrough = True
                .Color = OriginalWordColor
            End With
        Next i
    
    ' 修正後の文字が存在する場合、文字色を青に変更する。    
        If corrected_word <> "" Then
            For i = 0 To UBound(WordLocate) - 1
                target_range.Characters(Start:=WordLocate(i) + Len(original_word), _
                                        Length:=Len(corrected_word)).Font.Color = CorrectedWordColor
            Next i
        End If
    Exit Sub

er1:
    MsgBox errMsg(errIndex)

End Sub

早速、試してみましょう。

Sub CorrectTest()
    Call CorrectWord(Selection, "ばなな", "バナナ")
End Sub

これは久々の会心の出来！と思ったのも束の間、大変な欠陥があることに気づきました。試しに追加で、先ほどの文章を「おやつに入ります」にしてみましょう。

最初の修正で施された処理が解除されたうえに、全体的に何だか良く判らないものになってしまいました。直前に修正があるかもしれないことを、考慮していなかったためです。
直前の修正をどのように保持すれば・・・と考えてみましたが、脳みそが爆発したので、そこで考えるのをやめました。

というわけで、このマクロ、一つのセルにつき一回だけなら使えます。
二回目以降は、手作業での修正が必要です。

※試す場合、必ず直前に保存するようお願いします。

参考まで。

～ 追記 ～　2018.08.10
thomさんが、このテーマを完成させてくださいました。
いつも有難うございます。

thom.hateblo.jp