テーブルから別テーブルへの転記 ③ 配列と連想配列の組合せ　～その３．新規レコード追加～

前回はテーブル間の転記について、キー列情報を元にテーブル全体をガバッと転記することに挑戦した。
infoment.hatenablog.com
前回までは、転記元に新規に追加されたレコードのキーが転記先にない場合、
そのレコードは転記されない仕様になっていた。

ということで今回は、それも含めて転記することに挑戦する。
f:id:Infoment:20210803064554p:plain

今回はまず、前回までの成果物のうち、考慮漏れがあった個所を修正する。
それは、テーブルで列番号を取得しようとした際、そもそも指定したラベルが
テーブルになかった場合のエラーに対する処置だ（対象は２つ）。

とりあえず、エラーがあったらプロシージャ末まで飛ばし、イミディエイトに
メッセージを出すことにした（後日、何かしら変更するかも）。

↓ 転記元テーブル（に限らないが）から、連想配列を作成する関数。

' テーブル内の指定２列から辞書を作成する関数。
' ※同一キーが複数回登場しない前提で使用する。
' ※もし複数回登場したならば、itemは上書きされる。
Function CreateDict(target_tb As ListObject, key_index As Variant, item_index As Variant) As Object
    
    ' 作業用の辞書。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' テーブルにkeyまはたitemとなる列が存在しない場合のためのエラートラップ。
        On Error GoTo er:
    
    ' key列の列番号取得（key_indexがラベル名の場合に対応している）。
    Dim keyIndex As Long
        keyIndex = target_tb.ListColumns(key_index).index
    
    ' item列の列番号取得（item_indexがラベル名の場合に対応している）。
    Dim ItemIndex As Long
        ItemIndex = target_tb.ListColumns(item_index).index
        
        On Error GoTo 0
        
    Dim ListRow As Excel.ListRow
        
        ' keyが空白の場合は、辞書に登録しない。
        For Each ListRow In target_tb.ListRows
            If ListRow.Range(keyIndex).Value <> vbNullString Then
                Dict(ListRow.Range(keyIndex).Value) = ListRow.Range(ItemIndex).Value
            End If
        Next
        
    Set CreateDict = Dict
    
    Exit Function
    
er:
    Debug.Print "keyまたはitem列が、指定テーブルに存在しません。"
End Function

↓ 単列を転記して、転記先テーブルを返す関数。

' テーブル間のデータ受け渡し。
' 各テーブルの指定列をkeyに、別の指定列をitemとして授受する。
' ※転記先テーブルにあって転記元テーブルに無いレコードは保持される。
Function Transcription_Tb2Tb(src_tb As ListObject, dst_tb As ListObject, _
                             src_key As Variant, src_item As Variant, _
                    Optional dst_key As Variant, _
                    Optional dst_item As Variant) As Excel.ListObject

    Dim DstKey As Variant
        DstKey = dst_key: If IsError(DstKey) Then DstKey = src_key
    Dim DstItem As Variant
        DstItem = dst_item: If IsError(DstItem) Then DstItem = src_item

    ' 転記元テーブルで連想配列を作成できなかった場合の処理。
    Dim SrcDict As Object
    Set SrcDict = CreateDict(src_tb, src_key, src_item)
        If SrcDict Is Nothing Then
            Debug.Print "転記元テーブルで連想配列を作成できませんでした。"
            Exit Function
        End If
    
    ' テーブルにkeyまはたitemとなる列が存在しない場合のためのエラートラップ。
        On Error GoTo er:
    Dim DstKeyArray As Variant
        DstKeyArray = dst_tb.ListColumns(DstKey).DataBodyRange
    Dim DstItemArray As Variant
        DstItemArray = dst_tb.ListColumns(DstItem).DataBodyRange
        On Error GoTo 0
        
    Dim tempKey As Variant
        
    Dim i As Long
        For i = 1 To dst_tb.ListRows.Count
            tempKey = DstKeyArray(i, 1)
            If tempKey <> vbNullString Then
                If SrcDict.Exists(tempKey) Then
                    DstItemArray(i, 1) = SrcDict(tempKey)
                End If
            End If
        Next
        
        dst_tb.ListColumns(DstItem).DataBodyRange = DstItemArray
    Set Transcription_Tb2Tb = dst_tb
    
er:
    Debug.Print "keyまたはitem列が、指定テーブルに存在しません。"
    
End Function

さてそれでは前回で記載のとおり、ここからは、転記元のテーブルにキーがあって転記先のテーブルにキーがない場合の対応に挑戦する。作戦は、こんな感じだ。

転記先テーブルのキー列で、配列Ａを作成する。
転記元テーブルのキー列で、配列Ｂを作成する。
各配列を集合とみなし、差集合Ｂ－Ａを求める。
求まった差集合を、転記先テーブルに追加する。

なお、差集合Ｂ－Ａを求めるために、以前作成したこちらを利用した。
infoment.hatenablog.com
※これはクラスモジュールとしてまとめてあり、こちらに公開済みです。
infoment.hatenablog.com

ここで悩んだのが、この関数を使用する際、必ず上記クラスモジュールを
セットで運用するか？ということ。自分の中で答えは未だ出ていないが、
今はセットで運用する想定となっている。

ということで、昨日作成したものを改修したのがこちら。あれこれ想定しながら
追加したら、随分と長くなってしまった。

' テーブル間のデータ受け渡し。
' 転記元テーブルの指定列をkeyに、転記先テーブルにある全項目について転記する。
' ※転記先テーブルにあって転記元テーブルに無いレコードは保持される。
Function Transcription_Tb2Tb_All(src_tb As ListObject, _
                                 dst_tb As ListObject, _
                                 src_key As Variant, _
                        Optional dst_key As Variant, _
                        Optional add_new_record As Boolean = False) As Excel.ListObject
    
    ' 転記元にあって転記先にないkey情報の転記（選択可）。
    Dim SrcKeyArray As Variant
    Dim DstKeyArray As Variant
    Dim DifferenceSet As Variant
    ' 集合クラス
    Dim MS As VBAProject.MathSet
    Set MS = New VBAProject.MathSet
        If add_new_record Then
        
            On Error GoTo er:
            ' 転記元のkey情報を格納した配列。
            SrcKeyArray = src_tb.ListColumns(src_key).DataBodyRange
            
            ' 転記先のkey情報を格納した配列。
            If dst_tb.ListRows.Count = 0 Then
                DstKeyArray = Array()
            Else
                DstKeyArray = dst_tb.ListColumns(src_key).DataBodyRange
            End If
            On Error GoTo 0
            
            ' 「転記元」－「転記先」。
            ' ※数学の「集合」は、英語で「Set」（見た目ややこしい）。
            ' ※差分が存在しない、つまり新たなレコードが無い場合、空配列を返す。
            DifferenceSet = MS.GetDifferenceSet(DstKeyArray, SrcKeyArray, False)
            
            ' 空配列のUboundは「-1」であることを利用して、処理を場合分け。
            If UBound(DifferenceSet) <> -1 Then
            
                ' 転記先テーブルに一行追加したうえで、差分情報を貼り付け。
                ' ※テーブル範囲は、貼り付けレコードのサイズに合わせて
                ' 　自動的に拡張される。
                With dst_tb.ListRows.Add
                    .Range(dst_tb.ListColumns(src_key).index). _
                        Resize(UBound(DifferenceSet) + 1) = _
                            WorksheetFunction.Transpose(DifferenceSet)
                End With
            End If
        End If

    Dim ItemLabel As Variant
    Dim SrcItem As Variant
    
        ' 転記先の、keyラベルを除く全ての列名で転記をループ。
        For Each ItemLabel In src_tb.HeaderRowRange
            SrcItem = ItemLabel.Value
            If SrcItem <> src_key Then
                Transcription_Tb2Tb src_tb, dst_tb, src_key, SrcItem, dst_key
            End If
        Next
    
    ' 転記先のテーブルを戻り値としてセット。
    Set Transcription_Tb2Tb_All = dst_tb

er:
    Debug.Print "keyまたはitem列が、指定テーブルに存在しません。"
    
End Function

それでは、↓ こちらのテーブルで確認してみよう。
コードをキーに、テーブルＤの情報をテーブルＡに転記する。
f:id:Infoment:20210803200112p:plain

テスト用モジュールがこちら。

Sub test5()

    Transcription_Tb2Tb_All src_tb:=ActiveSheet.ListObjects("テーブルD"), _
                            dst_tb:=ActiveSheet.ListObjects("テーブルA"), _
                            src_key:="コード", _
                            add_new_record:=True

End Sub