テーブルから別テーブルへの転記 ③ 配列と連想配列の組合せ

前回はテーブル間の転記について、連想配列を用いて行う方法を紹介した。
infoment.hatenablog.com
今回は、配列と連想配列の組み合わせによる転記に挑戦する。
f:id:Infoment:20210801133909p:plain

前回に続き、こちらのテーブルを使用する。
f:id:Infoment:20210731145200p:plain

作戦は、こんな感じだ。

１．転記元テーブルのキー列とアイテム列で連想配列を作成する

今回の例でいえば、転記元はテーブルＢとなる。
f:id:Infoment:20210801135543p:plain
「コード」を手掛かりに転記を行うので、

「A001」を入れれば「7」
「A003」を入れれば「10」

を返してくれる連想配列とする。

２．転記先のキー列とアイテム列をそれぞれ配列に格納する

今回の例でいえば、転記元はテーブルＡとなる。
f:id:Infoment:20210801140213p:plain

３．key配列と連想配列の照合

key配列の値を、上から順に確認する。もし連想配列に存在するなら、
keyの値に対応するitem値をitem配列に上書きする。
f:id:Infoment:20210801140819p:plain
元々の値は保持され、転記元にkeyがあったもののみが、新たな情報として
上書きされる。

４．item配列を転記先テーブルに戻す

item配列を作成した列に、編集後のものを上書きする。
f:id:Infoment:20210801141222p:plain
貼り付け作業に於いて、変更の有無は問う必要がないため（＝今回は
テーブルＢに無いレコードは値が保持されているため）単純に上から
ペタッと貼り付けることができる。

５．転記完了

結果、このようになる。
f:id:Infoment:20210801141512p: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列の列番号取得（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
        
    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
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 = vbNullString, _
                    Optional dst_item As Variant = vbNullString) As Excel.ListObject
    
    Dim DstKey As Variant
        If dst_key = vbNullString Then DstKey = src_key Else DstKey = dst_key
    Dim DstItem As Variant
        If dst_item = vbNullString Then DstItem = src_item Else DstItem = dst_item

    Dim SrcDict As Dictionary
    Set SrcDict = CreateDict(src_tb, src_key, src_item)
    Dim DstKeyArray As Variant
        DstKeyArray = dst_tb.ListColumns(DstKey).DataBodyRange
    Dim DstItemArray As Variant
        DstItemArray = dst_tb.ListColumns(DstItem).DataBodyRange
    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

End Function

それでは、動作を確認してみよう。

Sub test3()    
    Transcription_Tb2Tb src_tb:=ActiveSheet.ListObjects(2), _
                        dst_tb:=ActiveSheet.ListObjects(1), _
                        src_key:="コード", _
                        src_item:="数量"
End Sub