元の文字列を残し訂正線を引いたうえで、訂正後の文字を改行して追加したい ②

昨日は、以下の依頼解決に挑戦したときの「さわり」を紹介した。

元の文字列を残し訂正線を引いたうえで、訂正後の文字を改行して追加したい

infoment.hatenablog.com

すると追加で、次のような依頼に発展した。

これを複数パターンで、複数範囲にわたって実行したい。

でしょーね。普通、そうなるわな。大丈夫、検討済みだ。
f:id:Infoment:20190719230040p:plain

今回の作戦は、↓ こうだ。

変更前・変更後のテーブルを準備しておく。
変更前をキーに、変更後をアイテムとして、辞書（連想配列）を作成する。
キー毎に検索し、ヒットした全てに訂正処理を行う。

なお、検索には、以前作成したFindAllを用いる。
↓ 再掲。

Function FindAll(target_range As Range, _
                 faWhat As String, _
        Optional faLookIn As Excel.XlFindLookIn = xlValues, _
        Optional faLookAt As Excel.XlLookAt = xlPart, _
        Optional faMatchCase As Boolean = False, _
        Optional faMatchByte As Boolean = False) As Range

    Dim FindCell As Range
    Dim FoundCell As Range
    Dim TempRange As Range
    
    '対象を全て選択するため、検索の開始位置や向きなどは指定していない。
    Set FindCell = target_range.Find(faWhat, _
                                     , _
                                     faLookIn, _
                                     faLookAt, _
                                     , _
                                     , _
                                     faMatchCase, _
                                     faMatchByte)
    
        If FindCell Is Nothing Then
            Exit Function
        Else
            Set FoundCell = FindCell
            Set TempRange = FindCell
        End If
        
        Do
            Set FindCell = target_range.Find(faWhat, FindCell)
            If FindCell.Address = FoundCell.Address Then
                Exit Do
            Else
                Set TempRange = Union(TempRange, FindCell)
            End If
        Loop

    Set FindAll = TempRange
End Function

昨日作成した分も載せておく。

Sub CorrectCharacter(target_range As Range, _
                     source_chara As String, _
                     corrected_chara As String)
    ' 文字列の結合
        target_range = source_chara & vbNewLine & corrected_chara
    
    ' 先頭から訂正前までの文字列分、訂正線を追加する。
        target_range.Characters(Start:=1, Length:=Len(source_chara)). _
        Font.Strikethrough = True
End Sub

昨日作成した内容は、そのまま使用する。変わるのは、これらを用いて処理する側のみだ。テスト用に準備したデータがこちら。
f:id:Infoment:20190719230550p:plain

左上のテーブルが、変更の前後を管理している。
これらを変更対象範囲に適用するマクロが ↓ こちら。

Sub test()
    Application.ScreenUpdating = False

    ' 変更前・変更後の値で辞書（連想配列）作成
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    Dim ListRow As Excel.ListRow
        For Each ListRow In ActiveSheet.ListObjects(1).ListRows
            With ListRow.Range
                Dict(.Cells(1).Value) = .Cells(2).Value
            End With
        Next
    
    ' 変更前の値で対象範囲を検索。
    ' 該当するものがあれば、全て変更後の値を追加したうえで、
    ' 元の値に訂正線を引く。
    Dim TargetRange As Range
    Dim r As Range
    Dim myKey As Variant
        For Each myKey In Dict.Keys
            Set TargetRange = FindAll(Range("D6:H13"), CStr(myKey))
            If Not TargetRange Is Nothing Then
                For Each r In TargetRange
                    CorrectCharacter r, CStr(myKey), Dict(myKey)
                Next
            End If
        Next
    
    Application.ScreenUpdating = True
    MsgBox "処理完了"
End Sub