ＶＢＡを用いた集合の理解 ⑥ まとめ

先日から高校数学の学び直しとして、ＶＢＡを用いた集合の理解に挑戦していた。
infoment.hatenablog.com
今日は、今までのまとめから。

ここしばらく業務で使ってみたが、個人的にはそれなりに重宝している。
例えば、こんな感じだ。

1. 帳票Ａを、日々更新する。その元となるのは、データＢである。
2. データＢと帳票Ａをキー情報で照合する。
3. データＢにあって帳票Ａにないものを、新規データとして帳票Ａに転記する。
   ※様々に処理したうえでの転記。

今回はお試しで、なんちゃって個人情報（5000人）を二つ準備した。
この中で、両なんちゃってに存在する名前を探してみよう。

Sub test()

    Dim MS As VBAProject.MathSet
    Set MS = New VBAProject.MathSet
        
    Dim arr1 As Variant
        arr1 = Sheets("Sheet1").ListObjects(1).ListColumns("名前").DataBodyRange
    Dim arr2 As Variant
        arr2 = Sheets("Sheet2").ListObjects(1).ListColumns("名前").DataBodyRange
    Dim arr3 As Variant
        arr3 = MS.GetIntersectionSet(arr1, arr2)
        MsgBox Join(arr3, vbNewLine)
        
End Sub

以降、この方々の情報を新規登録する処理に続くわけだ。

それでは、今までのクラスモジュール全文を載せておこう。

◆ソースコード（クリックで展開）◆

Option Explicit

' このクラス内で**Setや**_setと表現されるものはすべて、
' 数学における「集合（set）」を指している。
' ※ややこしいのでご注意ください。

' このクラス内では、集合はすべてｎ次元配列で表現する。
' 例）集合：果物 = Array("りんご", "みかん", "ばなな")

' 全体集合
Public UniversalSet As Variant

' 空集合（＝空配列）
Public Property Get EmptySet() As Variant
    EmptySet = Array()
End Property

' 配列の次元数を取得。
' ※配列ではない場合、戻り値は０となる。
Public Property Get Dimensionality(source_array As Variant) As Long
    If Not IsArray(source_array) Then
    Else
        Dim i As Long: i = 1
        Dim Temp As Long
            On Error Resume Next
            Do
                Dimensionality = i - 1
                Temp = UBound(source_array, i)
                If Err.Number <> 0 Then
                    Exit Do
                Else
                    i = i + 1
                End If
            Loop
            On Error GoTo 0
    End If
    
End Property

' 指定文字列が、ある集合の要素であるか否かを返す。
' a ∈ Ａ：ａは集合Ａの要素である。
Public Function IsElement(ByVal Element As Variant, _
                          ByVal target_set As Variant, _
                       Optional LookAt As XlLookAt = xlWhole) As Boolean
        
    ' 集合ではないものが指定された場合、Falseを返す。
        If Not IsArray(target_set) Then Exit Function
    
    ' 配列内の値と順にElementを照合し、同じものがある時点でTrueを返す。
    ' 従って、この関数はtarget_set内で複数の同じ値が含まれる場合を除外しない。
    ' なお、同じ文字であっても型が違えば別物として扱う。
    ' したがって、ここでは両者を強制的に文字列型に変換している。
    Dim a As Variant
        Element = CStr(Element)
        If LookAt = xlPart Then Element = "*" & Element & "*"
    
        For Each a In target_set
            If CStr(a) Like Element Then
                IsElement = True
                Exit Function
            End If
        Next
        
End Function

' コレクションから一次元配列を作成する。
Public Function ToArray(source_col As Collection) As Variant
    Dim arr() As Variant
    ReDim arr(1 To source_col.Count)
    Dim i As Long
        For i = 1 To source_col.Count
            arr(i) = source_col.Item(i)
        Next
    
        ToArray = arr
        
End Function

' 指定文字列を、ある集合に追加する。
' ※「ある集合」を強制的に１次元配列とし、その末尾に「指定文字列」を追加。
Public Function AddElement(ByVal Element As Variant, _
                           ByVal target_set As Variant, _
                        Optional duplicable As Boolean = True) As Variant
    
        ' 指定文字列がすでに集合に含まれている場合。
        If IsElement(Element, target_set) Then
            If Not duplicable Then
                AddElement = EmptySet
                Exit Function
            End If
        End If
        
    ' 上記以外の場合、いったん全てコレクションに格納ののち、一次元配列に
    ' 格納しなおす。
    Dim col As Collection
    Set col = New Collection
    Dim a As Variant
        For Each a In target_set
            col.Add a
        Next
        col.Add Element
        
        AddElement = ToArray(col)
        
End Function

' 指定文字列を、ある集合から除去する。
' ※「ある集合」は強制的に、一次元配列に変換される。
' ※「ある集合」に指定文字列が複数ある場合、すべて除去する。
Public Function RemoveElement(ByVal Element As Variant, _
                              ByVal target_set As Variant) As Variant
    
    ' 指定文字列が集合に含まれていない場合、空集合を返す。
    If Not IsElement(Element, target_set) Then
        RemoveElement = EmptySet
        Exit Function
    End If
        
    ' 上記以外の場合、指定文字を除く配列を作成する。
    Dim col As Collection
    Set col = New Collection
    Dim a As Variant
        For Each a In target_set
            If a <> Element Then
                col.Add a
            End If
        Next
        
        RemoveElement = ToArray(col)
        
End Function

' 集合Ａが、集合Ｂに含まれるか否かを確認する（真部分集合）。
' Ａ ⊂ Ｂ
' ※配列Ａと配列Ｂの次元数が一致していなくとも、配列Ａの
' 　全ての要素が配列Ｂに包含されているならば、Trueを返す。
Public Function IsProperSubset(ByVal set_A As Variant, _
                               ByVal set_B As Variant) As Boolean
                         
        If Not IsArray(set_A) Or Not IsArray(set_B) Then Exit Function
    
    Dim a As Variant
        
        ' ＢにないものがＡにあれば、その時点で部分集合ではない。
        For Each a In set_A
            If Not IsElement(a, set_B) Then
                Exit Function
            End If
        Next
        
        ' 上述の処理を経たうえで、Ｂにあるものが全てＡにあれば、
        ' ＡとＢは等しいといえる（真部分集合とは言えない）。
        ' 従って、ＢにあってＡにないものが一つでも存在する時点で、
        ' ＡはＢの真部分集合（Ａ⊂Ｂ）と言える。
        For Each a In set_B
            If Not IsElement(a, set_A) Then
                IsProperSubset = True
            End If
        Next

End Function

' 集合Ａが、集合Ｂと等しいか否かを確認する。
' Ａ＝Ｂ
' ※配列Ａと配列Ｂの次元数が一致していなくとも、配列Ａと
' 　配列Ｂの要素が互いにすべて含まれるならば、Trueを返す。
Public Function IsEqual(ByVal set_A As Variant, _
                        ByVal set_B As Variant) As Boolean
                        
        If Not IsArray(set_A) Or Not IsArray(set_B) Then
            Exit Function
        End If
        
    Dim a As Variant
        For Each a In set_A
            If Not IsElement(a, set_B) Then
                Exit Function
            End If
        Next
        
        For Each a In set_B
            If Not IsElement(a, set_A) Then
                Exit Function
            End If
        Next
        
        IsEqual = True
        
End Function

' 集合Ａが、集合Ｂに含まれるか否かを確認する（部分集合）。
' Ａ ⊆ Ｂ
' ※配列Ａと配列Ｂの次元数が一致していなくとも、配列Ａの
' 　全ての要素が配列Ｂに包含されているかまたは等しいなら
'　 Trueを返す。
Public Function IsSubset(ByVal set_A As Variant, _
                         ByVal set_B As Variant) As Boolean
                        
        If Not IsArray(set_A) Or Not IsArray(set_B) Then
        ElseIf IsProperSubset(set_A, set_B) Or IsEqual(set_A, set_B) Then
            IsSubset = True
        End If
        
End Function

Public Function SortArray(ByVal source_array As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
                       
    Dim aryList As Object
    Set aryList = CreateObject("System.Collections.ArrayList")
    Dim s As Variant
    
        For Each s In source_array
            Call aryList.Add(s)
        Next
    
        Select Case sort_order
            Case xlAscending
                ' 昇順でソート。
                Call aryList.Sort
            Case xlDescending
                ' 昇順でソートののち、降順へ反転。
                Call aryList.Sort
                Call aryList.Reverse
        End Select
    
        SortArray = aryList.ToArray
        
End Function

' 集合Ａと集合Ｂの和集合を取得。
' Ａ ∪ Ｂ
' ※配列Ａと配列Ｂの次元数に関わらず、ＡまたはＢの要素全てを
' 　一次元配列に格納する。
' ※ＡまたはＢ内で重複していた要素は、この処理により重複除去される。
' ※型は強制的に文字列型へ変換する。
' ※空白要素は、この過程で強制除去する。
Public Function GetUnionSet(ByVal set_A As Variant, _
                            ByVal set_B As Variant, _
                         Optional sort_order As Excel.XlSortOrder) As Variant

        If Not IsArray(set_A) Or Not IsArray(set_B) Then Exit Function
    
    Dim a As Variant
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        
        ' 連想配列の「キーの重複を認めない」仕様を利用して、重複除去している。
        ' 従ってキーに対応するアイテムは不問であり、今回はキーそのものをセットしている。
    Dim arr As Variant
        For Each arr In Array(set_A, set_B)
            For Each a In arr
                If a <> vbNullString Then
                    Dict(CStr(a)) = a
                End If
            Next
        Next
        
        arr = Dict.Keys
        If sort_order <> 0 Then
            arr = SortArray(arr, sort_order)
        End If
        
        GetUnionSet = arr

End Function

' 集合Ａと集合Ｂの積集合を取得。
' Ａ ∩ Ｂ
' ※配列Ａと配列Ｂの次元数に関わらず、ＡまたはＢの要素全てを
' 　一次元配列に格納する。
' ※ＡまたはＢ内で重複していた要素は、この処理により重複除去される。
' ※型は強制的に文字列型へ変換する。
' ※空白要素は、この過程で強制除去する。
Public Function GetIntersectionSet(ByVal set_A As Variant, _
                                   ByVal set_B As Variant, _
                                Optional sort_order As Excel.XlSortOrder) As Variant

        If Not IsArray(set_A) Or Not IsArray(set_B) Then Exit Function
        
        ' ＡとＢのどちらか一方でも空集合の場合、積集合は空集合となる。
        If UBound(set_A) = -1 Or UBound(set_B) = -1 Then
            GetIntersectionSet = EmptySet
            Exit Function
        End If
    
    Dim a As Variant
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        
        ' 連想配列の「キーの重複を認めない」仕様を利用して、重複除去している。
        ' 従ってキーに対応するアイテムは不問であり、今回はキーそのものをセットしている。
        For Each a In set_A
            If a <> vbNullString Then
                If IsElement(a, set_B) Then
                    Dict(CStr(a)) = a
                End If
            End If
        Next
        
        ' 辞書に何も登録されていない場合、積集合は存在しない。
        If Dict.Count = 0 Then
            GetIntersectionSet = EmptySet
            Exit Function
        End If

    Dim arr As Variant
        arr = Dict.Keys
        If sort_order <> 0 Then
            arr = SortArray(arr, sort_order)
        End If
        
        GetIntersectionSet = arr

End Function

' 集合Ａと集合Ｂの差集合を取得。
' Ｂ－Ａ
' ※配列Ａと配列Ｂの次元数に関わらず、ＡまたはＢの要素全てを
' 　一次元配列に格納する。
' ※ＡまたはＢ内で重複していた要素は、この処理により重複除去される。
' ※型は強制的に文字列型へ変換する。
' ※空白要素は、この過程で強制除去する。
Public Function GetDifferenceSet(ByVal set_A As Variant, _
                                 ByVal set_B As Variant, _
                       Optional check_subset As Boolean = True, _
                       Optional sort_order As Excel.XlSortOrder) As Variant

        If Not IsArray(set_A) Or Not IsArray(set_B) Then Exit Function
        
        ' 配列Ａが配列Ｂに内包されているか確認。
        ' これを不問とする場合、配列Ａが配列Ｂに存在しない要素を含んでいても関係なく、
        ' 単に配列Ａと配列Ｂとに共に存在する要素を引くことになる。
        If check_subset Then
            If Not IsSubset(set_A, set_B) Then
                GetDifferenceSet = EmptySet
                Exit Function
            End If
        End If
        
    Dim a As Variant
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
        ' まず、集合Ｂの要素を全て辞書に登録する。
        ' 次いで、集合Ａの要素が辞書に存在する場合、
        ' 辞書から除去していく。
        ' 最終的に残った辞書のキーが、Ｂ－Ａとなる。
        For Each a In set_B
            ' 必要なのはkey情報のみ。item情報は不問のため、
            ' 何でもよい。今回は簡単のため「1」をセット。
            If a <> vbNullString Then
                Dict(CStr(a)) = 1
            End If
        Next
        
        For Each a In set_A
            If a <> vbNullString Then
                If Dict.Exists(CStr(a)) Then
                    Dict.Remove CStr(a)
                End If
            End If
        Next
        
        ' 辞書に何も登録されていない場合、差集合は存在しない。
        If Dict.Count = 0 Then
            GetDifferenceSet = EmptySet
            Exit Function
        End If

    Dim arr As Variant
        arr = Dict.Keys
        If sort_order <> 0 Then
            arr = SortArray(arr, sort_order)
        End If
        
        GetDifferenceSet = arr
        
End Function

' 集合Ａの補集合を取得。
' 上記差集合における集合Ｂが、特に全体集合Ｕであるとき。
' Ｕ－Ａ
' ※配列Ａと配列Ｕの次元数に関わらず、ＡまたはＵの要素全てを
' 　一次元配列に格納する。
' ※ＡまたはＵ内で重複していた要素は、この処理により重複除去される。
Public Function GetComplementarySet(ByVal set_A As Variant, _
                                 Optional sort_order As Excel.XlSortOrder) As Variant

    GetComplementarySet = GetDifferenceSet(set_A, UniversalSet, sort_order)
        
End Function

Public Function GetRangeAddress(target_range As Range) As Variant
    Dim arr As Variant
        ' 配列のサイズをtarget_rangeと揃えるために、
        ' 一旦、target_rangeの値を配列に格納する。
        ' ※これらの値は、その後全て上書きされる。
        arr = target_range
        
    Dim rIndex As Long
    Dim cIndex As Long
        For rIndex = 1 To target_range.Rows.Count
            For cIndex = 1 To target_range.Columns.Count
                arr(rIndex, cIndex) = target_range.Cells(rIndex, cIndex).Address
            Next
        Next
        
        GetRangeAddress = arr
End Function

' 範囲Ｂから範囲Ａを除いた、新たな範囲を取得。
Public Function GetDifferenceRange(Range_A As Range, _
                                   Range_B As Range) As Range
    Dim set_A As Variant
        set_A = GetRangeAddress(Range_A)
    Dim set_B As Variant
        set_B = GetRangeAddress(Range_B)
        
    Dim DifferenceAddressArray As Variant
        ' とにかく除去できれば良いので、set_Aがset_Bの部分集合で
        ' あるか否かは問わない（=３つ目の引数をFalseとする）。
        DifferenceAddressArray = GetDifferenceSet(set_A, set_B, False)
    
        If UBound(DifferenceAddressArray) = -1 Then Exit Function
        
    Dim a As Variant
    Dim TempRange As Range
        For Each a In DifferenceAddressArray
            If TempRange Is Nothing Then
                Set TempRange = Range(a)
            Else
                Set TempRange = Union(TempRange, Range(a))
            End If
        Next
                        
    Set GetDifferenceRange = TempRange

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, _
                    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
    Dim DstItemArray As Variant
        Select Case dst_tb.ListRows.Count
            Case 1
                ReDim DstKeyArray(1 To 1, 1 To 1)
                DstKeyArray(1, 1) = dst_tb.ListColumns(DstKey).DataBodyRange
                ReDim DstItemArray(1 To 1, 1 To 1)
                DstItemArray(1, 1) = dst_tb.ListColumns(DstItem).DataBodyRange
            Case Else
                DstKeyArray = dst_tb.ListColumns(DstKey).DataBodyRange
                DstItemArray = dst_tb.ListColumns(DstItem).DataBodyRange
        End Select
        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

' テーブル内の指定２列から辞書を作成する関数。
' ※同一キーが複数回登場しない前提で使用する。
' ※もし複数回登場したならば、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に、転記先テーブルにある全項目について転記する。
' ※転記先テーブルにあって転記元テーブルに無いレコードは保持される。
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

        If IsMissing(dst_key) Then
            dst_key = src_key
        End If

        If add_new_record Then
        
            On Error GoTo er:
            ' 転記元のkey情報を格納した配列。
            SrcKeyArray = GetNotDuplicatedSet(src_tb, src_key)
            
            ' 転記先のkey情報を格納した配列。
            DstKeyArray = GetNotDuplicatedSet(dst_tb, dst_key)
            On Error GoTo 0
            
            ' 「転記元」－「転記先」。
            ' ※数学の「集合」は、英語で「Set」（見た目ややこしい）。
            ' ※差分が存在しない、つまり新たなレコードが無い場合、空配列を返す。
            DifferenceSet = GetDifferenceSet(DstKeyArray, SrcKeyArray, False)
            
            ' 空配列のUboundは「-1」であることを利用して、処理を場合分け。
            If UBound(DifferenceSet) <> -1 Then
            
                ' 転記先テーブルに一行追加したうえで、差分情報を貼り付け。
                ' ※テーブル範囲は、貼り付けレコードのサイズに合わせて
                ' 　自動的に拡張される。
                With dst_tb.ListRows.Add
                    .Range(dst_tb.ListColumns(dst_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 = GetIntersectionSet(LabelList, TargetList)
    
        ' 積集合で得られたラベル名を含めるか除外するかの場合分け。
        ' 除外する場合。
        If is_except Then
            LabelList = 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

Function NumToDate(target_tb As ListObject, ParamArray target_column() As Variant) As Excel.ListObject

    Dim TargetRange As Range
    Dim arr As Variant
    Dim i As Long
    Dim c As Long
    Dim Temp As Variant
    
        If IsMissing(target_column) Then Exit Function
        
        For c = 0 To UBound(target_column)
            Set TargetRange = target_tb.ListColumns(CStr(target_column(c))).DataBodyRange
            If Not TargetRange Is Nothing Then
            
                TargetRange.NumberFormatLocal = "G/標準"
                arr = TargetRange
                If Not IsArray(arr) Then
                    ReDim arr(1 To 1, 1 To 1)
                    arr(1, 1) = TargetRange
                End If
                
                For i = 1 To UBound(arr)
                    Temp = arr(i, 1)
                    If Temp = vbNullString Then
                    ElseIf Not IsNumeric(Temp) Then
                    ElseIf Len(Temp) = 8 Then
                        arr(i, 1) = Format(Temp, "0000/00/00")
                    End If
                Next
                
                TargetRange = arr
                TargetRange.NumberFormatLocal = "yyyy/mm/dd"
            End If
        Next
        
    Set NumToDate = target_tb
        
End Function

' テーブルとラベルを指定して、当該列のデータから「重複のない一次元配列」を作成する。
Function GetNotDuplicatedSet(target_tb As ListObject, target_column_index As Variant)
    Dim TargetColumnIndex As Long
        Select Case TypeName(target_column_index)
            Case "Integer", "Long", "String"
                TargetColumnIndex = target_tb.ListColumns(target_column_index).Index
            Case Else
                GetNotDuplicatedSet = Array()
                Exit Function
        End Select

    Dim Temp As Variant
        Select Case target_tb.ListRows.Count
            Case 0
                GetNotDuplicatedSet = Array()
                Exit Function
            Case 1
                Temp = Array(target_tb.ListColumns(TargetColumnIndex).DataBodyRange)
            Case Else
                Temp = target_tb.ListColumns(TargetColumnIndex).DataBodyRange
        End Select

        GetNotDuplicatedSet = GetUnionSet(Temp, Array())
        
End Function

以上、参考まで。