校閲ツールで修正した結果の履歴

Excel VBA クラスモジュール

昨日は、Excel で Word のように校閲するサブプロシージャを、ユーザーフォームに組み込んでみました。

infoment.hatenablog.com

これについて、はけたさんから「履歴を残してはどうか」とのご提案を頂きましたので、挑戦してみました。

今回はとりあえず、履歴管理用のシートを、校閲を行うブック内に作成することにしました。シートを作成するタイミングは、実際に文字列を置換するタイミングとします。そこで、作者であるthomさんには失礼して、Class_Initializeに少し追記しました。

Private Sub Class_Initialize()
    ReDim colorTextArray(0)
    ' 以下、追記箇所。
    Dim Ws As Worksheet
    For Each Ws In Worksheets
        If Ws.Name = HistorySheetName Then
            Exit Sub
        End If
    Next
    
    Dim CurrentSheet As Worksheet
    Set CurrentSheet = ActiveSheet
    
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = HistorySheetName
    Call MakeHistoryTable
    CurrentSheet.Select
End Sub

↓ 履歴記録用シート作成（クラスモジュール内）

Private Sub MakeHistoryTable()
    Cells(1, 1) = "シート名"
    Cells(1, 2) = "対象セル"
    Cells(1, 3) = "修正日"
    Cells(1, 4) = "修正前"
    Cells(1, 5) = "修正後"
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$E$1"), , xlYes).Name = "履歴テーブル"
    With ActiveSheet.ListObjects(1)
        .TableStyle = "TableStyleLight13"
        .ShowAutoFilterDropDown = False
    End With
End Sub

次いで、標準モジュールに以下を追記します。

Public Const HistorySheetName As String = "★校閲履歴"

↓ 履歴記録用プロシージャがこちらになります。

Sub RecordHistory(target_range As Range, original_word As String, correct_word As String)
    Dim HistoryTable As ListObject
    Set HistoryTable = Sheets(HistorySheetName).ListObjects(1)
    
    Dim AddRowIndex As Long
    On Error Resume Next
    AddRowIndex = HistoryTable.DataBodyRange.Rows.Count + 2
    If AddRowIndex = 0 Then AddRowIndex = 2

    With Sheets(HistorySheetName)
        .Cells(AddRowIndex, 1) = ActiveSheet.Name
        .Cells(AddRowIndex, 2) = target_range.Address(False, False)
        .Cells(AddRowIndex, 3) = Date
        .Cells(AddRowIndex, 4) = original_word
        .Cells(AddRowIndex, 5) = correct_word
    End With
End Sub

あとは、修正実行ボタンに組み込むだけです。
f:id:Infoment:20180824062151p:plain

Private Sub CorrectButton_Click()
    Dim r As Range
        For Each r In Selection
                Call CorrectWord(r, TextBox1.Value, TextBox2.Value) 
                ' ↓ この一行を追加。
                Call RecordHistory(r, TextBox1.Value, TextBox2.Value)
            End If
        Next
        TextBox1.Value = ""
        TextBox2.Value = ""
        TextBox1.SetFocus
End Sub

f:id:Infoment:20180825130027p:plain

f:id:Infoment:20180825130057p:plain

できた！・・・あれ？関係ないセルまで修正が行われたことになっている。そう、これでは修正があってもなくても、選択範囲分だけ記録されてしまうのです。さて、どうしたものか・・・。

そこで、これまた失礼して、thomさんに作成していただいたサブプロシージャを、Boolean型のファンクションプロシージャに変更しました。何某かの修正が行われた場合、Trueを返します。
※内容はほぼ一緒で、最後に数行追加しています。

Function CorrectWord( _
    target_range As Range, _
    original_word As String, _
    Optional corrected_word As String = "") As Boolean
        
    '以下でCellTextを実際の文字数よりも1つ多く確保しているのは、
    '空白セルを選んだときにインデックスエラーを回避するのと、
    'セルの内容が置換対象文字そのものだった場合に文字単位の
    'ヒットカウント(charPointer)が上手く機能しないトラブルを
    '回避するための苦肉の策。
    'なお、多めに確保したCellTextは中身が初期状態(vbNullString)
    'なので動作に悪影響を与えない。
    ReDim CellText(1 To Len(target_range.Value) + 1)
    
    '文字ごとにステータスを登録するフェーズ
    Dim i As Long
    For i = 1 To Len(target_range.Value)
        CellText(i).Text = Mid(target_range.Value, i, 1)
        CellText(i).State.Strikethrough = target_range.Characters(i, 1).Font.Strikethrough
        CellText(i).State.Replaced = target_range.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
 
    '今回の追記箇所
    Dim BeforeString As String
        BeforeString = target_range.Value
    
    '一気にセル書き出し
    CSO.WriteToCell target_range
    
    '今回の追記箇所
    If target_range.Value <> BeforeString Then
        CorrectWord = True
    Else
        CorrectWord = False
    End If
    
End Function

↓ 修正実行ボタンは、このように変更しました。

Private Sub CorrectButton_Click()
    Dim r As Range
        For Each r In Selection
            ' 今回の変更箇所
            If CorrectWord(r, TextBox1.Value, TextBox2.Value) = True Then
                Call RecordHistory(r, TextBox1.Value, TextBox2.Value)
            End If
        Next
        TextBox1.Value = ""
        TextBox2.Value = ""
        TextBox1.SetFocus
End Sub


↓ 結果、修正箇所のみ、履歴テーブルに反映できました。
f:id:Infoment:20180825131237p:plain

今回はここまでとしますが、いずれ修正確定も履歴の対象としたり、履歴テーブルの結果からＵＮＤＯするような仕掛けにも挑戦してみようと思います。

参考まで。