テーブルから別テーブルへの転記 ③ 配列と連想配列の組合せ　～その４．空白列を無視～

前回はテーブル間の転記について、転記先にキー情報がない場合は、
キーを追加したうえで情報を転記することに挑戦した。
infoment.hatenablog.com
前回までは、転記元が空白であって転記先に何らかの値が入っている場合、
無条件で空白を上書きしていた。

ということで今回は、それを選択できるよう改修してみよう。
f:id:Infoment:20210804230422p:plain

例えば、↓ このような場合。
f:id:Infoment:20210804230705p:plain

転記元：テーブルＤのA001，A003，A005は、日付が空欄になっている。一方で、
転記先：テーブルＡのA001，A003，A005は、日付が空欄ではない。
このようなとき、少なくとも

何某か日付が決まっていたものが、白紙に戻った。
一旦決まった日付は、テーブルＤ作成時に省略された。

の二パターンがあると思う。

そこで、テーブル間の転記用プロシージャに、空白無視を選択する引数を追加
することにした。

Optional ignore_blank As Boolean = False

True ：空白の場合は転記しない
False ：空白であっても転記する

基本的には、空白であっても無条件で転記することにしよう。

転記するかしないかは、ignore_blankの二択と、転記元が空欄か否かの二択の
掛け算になるから、４パターンが存在する。
f:id:Infoment:20210804231531p:plain

これを踏まえて、転記する条件を一つ追加したのがこちら。

' テーブル間のデータ受け渡し。
' 各テーブルの指定列を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, _
                    Optional ignore_blank As Boolean = False) As Excel.ListObject
                    ' ignore_blankは、空白の反映に関する設定。
                    ' Trueの場合、転記元のitemが空白であれば転記しない。

    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
                    ' 「空白無視の引数がTrue」で、且つ「実際に空白」の場合のみ転記しない。
                    ' 従ってその逆「空白無視しない または 空白以外」の場合に転記する。
                    If Not ignore_blank Or SrcDict(tempKey) <> vbNullString Then
                        DstItemArray(i, 1) = SrcDict(tempKey)
                    End If
                End If
            End If
        Next
        
        dst_tb.ListColumns(DstItem).DataBodyRange = DstItemArray
    Set Transcription_Tb2Tb = dst_tb
    
er:
    Debug.Print "keyまたはitem列が、指定テーブルに存在しません。"
    
End Function

全転記のプロシージャにも追加しよう。

' テーブル間のデータ受け渡し。
' 転記元テーブルの指定列を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, _
                        Optional ignore_blank 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:=src_tb, _
                                    dst_tb:=dst_tb, _
                                    src_key:=src_key, _
                                    src_item:=SrcItem, _
                                    dst_key:=dst_key, _
                                    ignore_blank:=ignore_blank
            End If
        Next
    
    ' 転記先のテーブルを戻り値としてセット。
    Set Transcription_Tb2Tb_All = dst_tb

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

それでは、冒頭の例で確認してみよう。
↓ この場合、アイテムが空白の場合は転記しない。

Sub test5()

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

End Sub