テーブルから別テーブルへの転記 ③ 配列と連想配列の組合せ　～その６．転記先にしかないキーを削除～

Excel VBA テーブル機能

前回はテーブル間の転記について、転記する列のラベル名を指定して転記
できるよう、機能拡張してみた。
infoment.hatenablog.com

今回は、転記先にしかないレコードキーの扱いについて考えてみる。
f:id:Infoment:20210807173513p:plain

例えば、このような場合において。
f:id:Infoment:20210807180029p:plain

転記先の「A002：みかん」と「A004：ぶどう」は、転記元には存在しない。
管理の内容にもよるが、例えば「転記されない＝非管理レコード」であるなら、
転記先から削除したいところ。

そこで今回、転記先にしかないキーの削除を選択できるようにしてみた。
追加したのは、こちらの引数。
f:id:Infoment:20210807174353p:plain

転記元になく、且つ、こちらの引数が「True」なら、転記先のキー列から削除
する作戦だ。
f:id:Infoment:20210807174605p:plain

最後に、キー列の値を丸ごとペタッと上書きして完成。
f:id:Infoment:20210807174710p: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, _
                    Optional del_key As Boolean = False) As Excel.ListObject
                    ' ignore_blankは、空白の反映に関する設定。
                    ' Trueの場合、転記元のitemが空白であれば転記しない。
                    
                    ' del_key：転記先のkeyが転記元に存在しない場合、そのキーを
                    ' 転記先から消すか否かを設定する。Trueであれば削除する。

    Dim DstKey As Variant
        If IsMissing(dst_key) Then DstKey = src_key Else DstKey = dst_key
    Dim DstItem As Variant
        If IsMissing(dst_item) Then DstItem = src_item Else DstItem = dst_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
                
                ' 転記元に存在せず、且つその場合にキー削除の設定の場合。
                ElseIf del_key Then
                    DstKeyArray(i, 1) = vbNullString
                End If
            End If
        Next
        
        dst_tb.ListColumns(DstItem).DataBodyRange = DstItemArray
        If del_key Then
            dst_tb.ListColumns(DstKey).DataBodyRange = DstKeyArray
        End If
        
    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, _
                        Optional target_list As Variant, _
                        Optional is_except As Boolean = False, _
                        Optional del_key As Boolean = False) As Excel.ListObject
    
    ' 画面更新の設定。現時点の設定を退避。
    Dim PresentScreenUpdating As Boolean
        PresentScreenUpdating = Application.ScreenUpdating
        
    ' 画面更新を一時停止。
        Application.ScreenUpdating = False
    
    ' 転記元にあって転記先にない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に引数を渡していない場合、IsMissingはTrueとなる。
        ' その場合、全てのラベルが転記対象となる。
        If IsMissing(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, _
                                    del_key:=del_key
            End If
        Next
    
    ' 画面更新の設定を元に戻す。
    Application.ScreenUpdating = PresentScreenUpdating
    
    ' 転記先のテーブルを戻り値としてセット。
    Set Transcription_Tb2Tb_All = dst_tb
    
    Exit Function

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

    ' 画面更新の設定を元に戻す。
    Application.ScreenUpdating = PresentScreenUpdating
    
End Function

それでは、こちらで確認してみよう。A002とA004が消えればＯＫだ。

Sub test6()

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

End Sub

結果がこちら。
f:id:Infoment:20210807175616g:plain

意図したとおり、A002とA004の二つが消えた。消す前に退避させたり、消した
後に行全体を削除したりなど、実際にはこれほど単純ではないことだろう。
これについては後日、改めて考えてみたい。

ということで、次回に続きます。

参考まで。