エクセルVBA100本ノック。１７本目：重複削除（ユニーク化）

この記事から得るもの

表の重複データの抽出方法。
Range.AdvancedFilterの使い方。
DictionaryとCollectionの違い。

１　今回のお題

画像1のように部・課・氏名の「社員」シートがあります。
このデータを基に、画像2のように部・課マスタを作成してください。
※部・課でユニーク化するという事ことです。
シート「部・課マスタ」は存在している前提で構いません。
※マスタなのでコード順にしてください。

f:id:bimori466:20201111082809p:plain
f:id:bimori466:20201111082851p:plain

excel-ubara.com

２　今回のお題の意図

大量のデータから重複しない値を抽出する。

３　回答

これは重複の削除を使えばＶＢＡ作る必要ないのでは？と思ったのですが、「Excel2016まではバグ報告がある」ということでした。
それアカンやん。知らない人多そう。

今回も、思いつかなかたので勉強回です。

第１に便利だと思ったのが、「Range.AdvancedFilter」です。
これで、Rangeから重複しない値を簡単に取り出すことができます。実際にコードを見てみましょう。

サイト管理者のコード

Dim ws社員 As Worksheet：Set ws社員 = Worksheets("社員")
Dim ws部課 As Worksheet：Set ws部課 = Worksheets("部・課マスタ")

    ws部課.Cells.Clear
    ws社員.Columns("C:F").AdvancedFilter Action:=xlFilterCopy, _
                                         CopyToRange:=ws部課.Range("A1"), _
                                         Unique:=True
  
    With ws部課
        .Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlAscending, _
                                        key2:=.Range("B1"), order2:=xlAscending, _
                                        Header:=xlYes
    End With
End Sub

処理手順
１　ws社員.Columns("C:F")の値をコピーする（Action:=xlFilterCopy）。
２　コピーしたセルの貼り付け先を選択する（CopyToRange:=ws部課.Range("A1")）。
３　重複は削除する（Unique:=True）。
４　貼り付け先のセルを部課コード順に並べ替える。

もっとも簡単な方法だと思いました。

もう一つの方法で「Dictionary」が気になりました。Twitter上でちょくちょく目にするのですが、実際に使ったことなかったので調べてみました。
結論、Keyが絶対必要なCollectionと理解しました。CollectionはKeyが必須ではありません。また、参照設定が必要なようです（実行時バインディングしない場合）。

サイト管理者の回答では、Dictionaryを使って「Keyの中に同じ値が存在するか」を条件分岐として重複しないデータを取得していました。
一方、私はCollectionを使って、サイト管理者の回答を参考にしつつ作成しました。Collectionの特性として、「重複したデータを入れることができない」のです。重複データを入れようとするとエラーになるので「On Error Resume Next」でエラーを無視します。

では、まずDictionaryを使ったコードから見ていきましょう。

サイト管理者のDictionaryを使用したコード

Sub VBA100_17_02()
    Dim ws社員 As Worksheet: Set ws社員 = Worksheets("社員")
    Dim ws部課 As Worksheet: Set ws部課 = Worksheets("部・課マスタ")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
  
    Dim i As Long, tmp As String
    With ws社員
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            tmp = .Cells(i, 3) & vbTab & .Cells(i, 4)
            If Not dic.exists(tmp) Then
                dic.Add tmp, .Cells(i, 3).Resize(, 4).Value
            End If
        Next
    End With
  
    ws部課.Range("A1").CurrentRegion.Offset(1).ClearContents
    Dim j As Long, v As Variant
    j = 2
    For Each v In dic.items
        ws部課.Cells(j, 1).Resize(, 4).Value = v
        j = j + 1
    Next
  
    With ws部課
        .Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlAscending, _
                                        key2:=.Range("B1"), order2:=xlAscending, _
                                        Header:=xlYes
    End With
End Sub

Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")で、実行時バインディングしているので、この書き方だと参照設定は必要ありません。

注目すべきは、重複しているかどうかのチェック方法です。
チェック部分は、「 If Not dic.exists(tmp) Then」です。
部コードと課コードをTabで繋げて「Key」として、Keyが存在しない場合はセルのデータ（Cells(i, 3).Resize(, 4).Value）をitemに入れるという処理です。
その後、 For Each v In dic.itemsで、dicのItemの内容をすべて部・課Sheetに書き出し、並べ替えて終了です。

では、Collectionの場合はどうなるのか。

私の考えたコード

Sub ノック17本目_1()

Dim ws社員 As Worksheet: Set ws社員 = Worksheets("社員")
Dim ws部課 As Worksheet: Set ws部課 = Worksheets("部・課マスタ")

Dim col As Collection: Set col = New Collection

'重複しない部コード、課コードの取得
For i = 2 To ws社員.Cells(Rows.Count, 1).End(xlUp).Row
    temp = ws社員.Cells(i, 3).Value & vbTab & ws社員.Cells(i, 4).Value
    
    On Error Resume Next
    col.Add ws社員.Cells(i, 3).Resize(, 4).Value, temp
Next

'エラー無視の解除
On Error GoTo 0

'取得したCollectionを、ws部課に書込み
Write_IX = 2
For Each colItems In col
    ws部課.Cells(Write_IX, 1).Resize(, 4).Value = colItems
    Write_IX = Write_IX + 1
Next

'並べ替え
With ws部課
    .Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlAscending, _
                                    key2:=.Range("B1"), order2:=xlAscending, _
                                    Header:=xlYes
End With

End Sub

col.Add ws社員.Cells(i, 3).Resize(, 4).Value, temp、ここでCollectionに、item,Keyを渡しています。
重複したitemを入れようとするとエラーになるので、「On Error Resume Next」でエラーを無視します。
Collectionに代入する処理が終わったら、エラーの無視を解除します「On Error GoTo 0」。

その後、For Each colItems In colで、部・課SheetにCollectionのItemを代入し、並べ替えます。