テーブルから別テーブルへの転記 ③ 配列と連想配列の組合せ　～その５．複数列をラベル名で指定～

前回はテーブル間の転記について、転記元が空白の場合は、転記先へ
上書きする／しないを選択できるようにしてみた。
infoment.hatenablog.com
ところで前回までは、一列転記するか全部転記するかの二択だった。
しかし、例えば10列の内7列だけ転記したい場合を考えると、まだまだ
使い勝手が良いとは言えない。

ということで今回は、ラベル名を複数選択して転記することに挑戦する。
f:id:Infoment:20210805205304p:plain

今回の作戦は、こうだ。
まず全転記のプロシージャに、引数を二つ追加する。
f:id:Infoment:20210805233238p:plain

target_list　指定ラベルを配列で与える（一つの場合は文字列）
is_except 　target_listだけ転記するか、それ以外を転記するか選択

最初、target_listはParamArrayで渡そうと考えていた。しかし、ParamArrayは
Optional 引数がある場合使用できない。いかんいかん、うっかりしてた。
www.excel-ubara.com

それで今回、先日のTranscription_Tb2Tb_Allに追加したのがこの部分。
細かい説明はコメントで代用。

    ' まず、転記元のラベル全体を配列に格納する。
    Dim LabelList As Variant
        LabelList = src_tb.HeaderRowRange
    
    ' 転記指定列の配列を受け取る。
    Dim TargetList As Variant
        TargetList = target_list
        
        ' target_listに引数を渡していない場合、IsErrorはTrueとなる（つまりエラー発生）。
        ' その場合、全てのラベルが転記対象となる。
        If IsError(TargetList) Then
            TargetList = LabelList
    
        ' TargetListが配列でない場合、それは文字列（ラベル）が一つ渡されたということ。
        ' この場合、要素が一つの配列に変換する。
        ElseIf Not IsArray(TargetList) Then
            TargetList = Array(target_list)
        End If
        
    ' 指定されたラベル名が､転記元テーブルのラベルに存在しない恐れがある。
    ' そこで、渡された指定ラベル名と転記元テーブルのラベル名の積集合を求めることで、
    ' ラベルの絞り込みを行うとともに、存在しないラベル名を除去する。
    Dim TempList As Variant
        TempList = MS.GetIntersectionSet(LabelList, TargetList)
    
        ' 積集合で得られたラベル名を含めるか除外するかの場合分け。
        ' 除外する場合。
        If is_except Then
            LabelList = MS.GetDifferenceSet(TempList, LabelList)
        
        ' 含める場合。
        Else
            LabelList = TempList
        End If

ファンクションプロシージャの全文がこちら。

' テーブル間のデータ受け渡し。
' 転記元テーブルの指定列を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, _
                        Optional target_list As Variant, _
                        Optional is_except 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 LabelList As Variant
        LabelList = src_tb.HeaderRowRange
    
    ' 転記指定列の配列を受け取る。
    Dim TargetList As Variant
        TargetList = target_list
        
        ' target_listに引数を渡していない場合、IsErrorはTrueとなる（つまりエラー発生）。
        ' その場合、全てのラベルが転記対象となる。
        If IsError(TargetList) Then
            TargetList = LabelList
    
        ' TargetListが配列でない場合、それは文字列（ラベル）が一つ渡されたということ。
        ' この場合、要素が一つの配列に変換する。
        ElseIf Not IsArray(TargetList) Then
            TargetList = Array(target_list)
        End If
        
    ' 指定されたラベル名が､転記元テーブルのラベルに存在しない恐れがある。
    ' そこで、渡された指定ラベル名と転記元テーブルのラベル名の積集合を求めることで、
    ' ラベルの絞り込みを行うとともに、存在しないラベル名を除去する。
    Dim TempList As Variant
        TempList = MS.GetIntersectionSet(LabelList, TargetList)
    
        ' 積集合で得られたラベル名を含めるか除外するかの場合分け。
        ' 除外する場合。
        If is_except Then
            LabelList = MS.GetDifferenceSet(TempList, LabelList)
        
        ' 含める場合。
        Else
            LabelList = TempList
        End If

    Dim ItemLabel As Variant
    Dim SrcItem As Variant
    
        ' 転記先の、keyラベルを除く全ての列名で転記をループ。
        For Each ItemLabel In LabelList
            SrcItem = ItemLabel
            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

先日から色々と増築を繰り返したため、随分長くなってしまった。

それでは、こちらで確認してみよう。
f:id:Infoment:20210805231849p:plain

今回は、商品名と数量を消してある。転記から商品名列を除外してみる。

Sub test6()

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

End Sub