VBA100本ノック 17本目：重複削除（ユニーク化）

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。

今回の出題は、実際の業務でも頻出する事例ではなかろうか。
出題内で特に制限されていなかったため、少しインチキして今回は、以下を
あらかじめテーブル書式で作成しておくことにした。

1. 社員リスト
2. 部・課マスタ　※ラベルのみ

今回は、課コードがユニークキーのようだ。そこでレコード毎に情報を転記し、
課コードを辞書に登録することで重複転記を防ぐこととした。

Sub VBA_100Knock_017()
        Application.ScreenUpdating = False
    Dim 社員リスト As ListObject
    Set 社員リスト = Sheets("社員").ListObjects(1)
    Dim 部門マスタ As ListObject
    Set 部門マスタ = Sheets("部・課マスタ").ListObjects(1)
        ' 部門マスタリセット。
        If 部門マスタ.ListRows.Count > 0 Then
            部門マスタ.DataBodyRange.Delete
        End If
    
    Dim 転記確認 As Object
    Set 転記確認 = CreateObject("Scripting.Dictionary")
    
    Dim リスト行  As Excel.ListRow
    Dim 部コード As Long
    Dim 課コード As Long
    Dim 部名称 As String
    Dim 課名称 As String
        For Each リスト行 In 社員リスト.ListRows
            部コード = リスト行.Range(社員リスト.ListColumns("部コード").index)
            課コード = リスト行.Range(社員リスト.ListColumns("課コード").index)
            部名称 = リスト行.Range(社員リスト.ListColumns("部名称").index)
            課名称 = リスト行.Range(社員リスト.ListColumns("課名称").index)
            ' 転記実績を辞書で確認。
            If Not 転記確認.Exists(課コード) Then
                With 部門マスタ.ListRows.Add
                    .Range(部門マスタ.ListColumns("部コード").index) = 部コード
                    .Range(部門マスタ.ListColumns("課コード").index) = 課コード
                    .Range(部門マスタ.ListColumns("部名称").index) = 部名称
                    .Range(部門マスタ.ListColumns("課名称").index) = 課名称
                End With
            ' 転記実績を登録。
                転記確認(課コード) = "転記済み"
            End If
        Next
                    
        ' 課コードでソート。
        部門マスタ.Sort.SortFields.Clear
        部門マスタ.Sort.SortFields.Add _
            Key:=部門マスタ.ListColumns("課コード").DataBodyRange, _
            Order:=xlAscending
        With 部門マスタ.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Application.ScreenUpdating = True
End Sub

手前味噌ではあるが、以前作成した自前のクラスモジュールを活用すると、
こんな記載も可能となる。
infoment.hatenablog.com

Sub VBA_100Knock_017_別解()
        Application.ScreenUpdating = False
    Dim 社員リスト As ListObject
    Set 社員リスト = Sheets("社員").ListObjects(1)
    Dim 部門マスタ As ListObject
    Set 部門マスタ = Sheets("部・課マスタ").ListObjects(1)
    
    Dim MaS As VBAProject.MathSet
    Set MaS = New VBAProject.MathSet
        ' テーブル間の転記。
        MaS.Transcription_Tb2Tb_All src_tb:=社員リスト, _
                                    dst_tb:=部門マスタ, _
                                    src_key:="課コード", _
                                    add_new_record:=True
        ' 課コードでソート。
        部門マスタ.Sort.SortFields.Clear
        部門マスタ.Sort.SortFields.Add _
            Key:=部門マスタ.ListColumns("課コード").DataBodyRange, _
            Order:=xlAscending
        With 部門マスタ.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Application.ScreenUpdating = True
End Sub

解答を実行した結果がこちら。

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。