二つの配列を比較する - Infomentのブログ～Excel VBA奮闘記～

昨日は、二次元配列で、最後尾に新たな一行または一列を追加してみた。
infoment.hatenablog.com

今日は、表で何某かレコードに変更があった場合を想定し、二次元配列に格納して比較することに挑戦する。
f:id:Infoment:20190910232335p:plain

今回も、北陸県を用いたサンプルで検討した。
f:id:Infoment:20190910232448p:plain

表Ａと表Ｂの違いは、以下の通り。

富山県の何某かの人数が２から５に変更。
石川県を削除
福井県を追加

試行錯誤しているうちに、深夜０時に突入しそう。なので今回は、コメントを充実させて説明に代えることとした。作成したサブプロシージャは、以下の二つ。

クラスモジュール（ArrayEditClass）

' 二つの配列を比較して、変更・追加・削除状況を調べた結果を返す。
Public Function CompareResultArray(arr As Variant, _
                          Optional key_index As Long = 1) As Variant

    ' 調査結果を記すため、配列の最後尾に一列追加。
    ColumnCutAndPaste cMax, cMax, xlCopy, cpInsert
    
    ' まず最終列に全て、「削除」をセット。
    ' 削除で無ければ、結果を上書きする。
    For r = rMin To rMax
        source_array(r, cMax) = "削除"
    Next
    
    ' 比較する配列のループカウンタ。
    Dim j As Long
    ' 検索キーワードが見つかった行番号。
    Dim k As Long
    ' 変更点の有無を知るためのカウンタ。
    Dim counter As Long
        For j = LBound(arr) To UBound(arr)
            counter = 0
            
            ' キー情報が調査対象となる配列に存在しない場合、それは
            ' 今回、対象配列に追加されたことを意味する。
            ' 従って、調査したレコードをそのままコピーし、最終列に
            ' 「追加」をセットする。
            If ColumnFind(arr(j, key_index)) Is Nothing Then
                RowCutAndPaste rMax, rMax, xlCopy, cpInsert
                For c = cMin To cMax - 1
                    source_array(rMax, c) = arr(j, c)
                Next
                source_array(rMax, cMax) = "追加"
            
            ' キー情報が対象配列に存在する場合、レコードの内容を
            ' 一つずつ比較する。一致しないものがあれば、「⇒」で
            ' つないでcounterをカウントアップ。
            Else
                k = ColumnFind(arr(j, key_index)).Item(1)
                For c = cMin To cMax - 1
                    If source_array(k, c) <> arr(j, c) Then
                        source_array(k, c) = source_array(k, c) & " ⇒ " & arr(j, c)
                        counter = counter + 1
                    End If
                Next
                
            ' カウンターが０ならば、レコード内容に変更なしを意味する。
            ' 従って、最終列の文字「削除」を削除する。
                If counter = 0 Then
                    source_array(k, cMax) = vbNullString
            
            ' カウンターが１以上の場合、何某かの変更があったことを意味する。
            ' 従って、最終列の文字を「変更」に変更する。
                Else
                    source_array(k, cMax) = "変更"
                End If
            End If
        Next
        
    CompareResultArray = source_array
End Function

' 指定列で指定キーワードを検索し、該当する
' 列番号をコレクションで返す。
Public Function ColumnFind(cf_What As Variant, _
                  Optional cf_LookAt As Excel.XlLookAt = xlWhole, _
                  Optional find_column_index As Long = 1) As Collection
    
    ' 部分一致で検索する場合、検索キーワードの前後にアスタリスクを追加。
    ' これにより、Like演算子で前後方一致とする。
    If cf_LookAt = xlPart Then
        cf_What = "*" & cf_What & "*"
    End If
    
    Dim col As Collection
    Set col = New Collection
    
    ' 一致する場合、その行番号をコレクションに格納。
    For r = rMin To rMax
        If source_array(r, find_column_index) Like cf_What Then
            col.Add r
        End If
    Next
    
    ' 一つ以上一致する場合のみ、取得したコレクションを返す。
    ' 該当行が無い場合、Nothingとなる。
    If col.Count >= 1 Then
        Set ColumnFind = col
    End If
End Function

毎度のテスト用コードがこちら。

Sub abe_shi()
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    
    Dim arr_1() As Variant
        arr_1 = Range("A2:C5").Value
    Dim arr_2 As Variant
        arr_2 = Range("A8:C11").Value
    Dim arr_result As Variant
        
        arr_result = SQC.TargetArray(arr_1).CompareResultArray(arr_2)
        SQC.TargetArray(arr_result).PasteArray Range("E1")

End Sub