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

公開日：2020-11-05　最終更新日：2021-02-22

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

重複を削除してユニーク化（一意化）する問題です。
社員データから、部・課マスタを作成します。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

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

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_17.xlsm
https://excel-ubara.com/vba100sample/VBA100_17.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

ユニーク化する方法は沢山あります。
・関数+（オートフィルター/1行ずつ抽出）
・並べ替えて上下比較
・Dictionaryを使う
・フィルターオプションの設定
・重複の削除
・ピボットテーブル
・Power Query
・UNIQUE関数
色々あますが、まずはフィルターオプションの設定から。


  
    
      Sub VBA100_17_01()

　　Dim ws社員 As Worksheet

　　Dim ws部課 As Worksheet

　　Set ws社員 = Worksheets("社員")

　　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

フィルターオプションの設定は、あくまでユニーク化にも使えるということであって、
何十万件から重複データを消すというような場合はお勧めしません。
次にユニーク化と言ったらDictionaryが思い浮かんだ人も多いのではないでしょうか。
Dictionaryは用途が広く、使い慣れると何かと便利です。


  
    
      Sub VBA100_17_02()

　　Dim ws社員 As Worksheet

　　Dim ws部課 As Worksheet

　　Set ws社員 = Worksheets("社員")

　　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

その他、関数+フィルター、並べ替えてから上下比較のVBAサンプルを記事補足に掲載しました。
方法は沢山あるので、いろいろ挑戦してみると面白いと思います。

補足

先のVBAのSortは古いSortメソッドで記述しました。
以下では、シートのSortオブジェクトを使った記述にしています。

関数+オートフィルター


  
    
      Sub VBA100_17_03()

　　Dim ws社員 As Worksheet

　　Dim ws部課 As Worksheet

　　Set ws社員 = Worksheets("社員")

　　Set ws部課 = Worksheets("部・課マスタ")

      　　

      　　ws部課.Cells.Clear

　　ws社員.Range("G1").Value = "判定"

　　With ws社員.Range("A1").CurrentRegion

      　　　　Intersect(.Cells, .Offset(1, 6)).Formula = "=COUNTIFS(C$2:C2,C2,D$2:D2,D2)"

　　　　.AutoFilter field:=7, Criteria1:=1

　　　　.Columns("C:F").Copy Destination:=ws部課.Range("A1")

　　　　ws社員.AutoFilterMode = False

　　　　.Columns(7).Delete

　　End With

　　

　　With ws部課.Sort

　　　　.SortFields.Clear

　　　　.SortFields.Add Key:=ws部課.Range("A1"), Order:=xlAscending

　　　　.SortFields.Add Key:=ws部課.Range("B1"), Order:=xlAscending

      　　　　.SetRange ws部課.Range("A1").CurrentRegion

      　　　　.Header = xlYes

　　　　.Apply

　　End With

End Sub

関数+1行ずつ抽出

For...Nextで1行ずつ判定していく方法になります。
上では関数をセルに入れて判定してところをVBAでWorksheetFunctionを使って判定し、判定結果で1行ずつコピーしていく方法になります。
この方法は寄せられた回答にありますので、ここでは割愛します。

並べ替えて上下比較


  
    
      Sub VBA100_17_04()

　　Dim ws社員 As Worksheet

　　Dim ws部課 As Worksheet

　　Set ws社員 = Worksheets("社員")

　　Set ws部課 = Worksheets("部・課マスタ")

　　

　　ws部課.Cells.Clear

　　ws社員.Columns("C:F").Copy Destination:=ws部課.Range("A1")

　　

　　With ws部課.Sort

　　　　.SortFields.Clear

　　　　.SortFields.Add Key:=ws部課.Range("A1"), Order:=xlAscending

　　　　.SortFields.Add Key:=ws部課.Range("B1"), Order:=xlAscending

      　　　　.SetRange ws部課.Range("A1").CurrentRegion

      　　　　.Header = xlYes

　　　　.Apply

　　End With

　　

　　Dim i As Long

　　With ws部課

　　　　For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1

　　　　　　If .Cells(i, 1) = .Cells(i - 1, 1) And _

　　　　　　　 .Cells(i, 2) = .Cells(i - 1, 2) Then

　　　　　　　　.Rows(i).Delete

　　　　　　End If

　　　　Next

　　End With

End Sub

対象となる列を全部コピーした後、
下行から上に向かって、上の行と同じなら行削除しています。
データ件数が多いと処理時間がかなりかかってしまうので、件数が多い場合は別の方法を検討してください。

重複の削除

簡単な方法ですが、当初からバグが報告されていて使うのを躊躇している人も多いと思います。
少なくとも、Excel2016まではバグ報告があるようですので、どうしても使う場合は注意してください。
特にデータ件数・列数が多かったり、列データに数値・文字が混在していたりする場合は要注意です。
VBAは、マクロ記録すればほぼそのまま使えるので、もし使うとしてもVBAを書くのに困ることは無いと思います。

ピボットテーブル

VBAの今回のお題には向かないと思います。
VBAで新規にピボットを作るのが大変です。
事前にシートに作成しておけば、データの更新だけなので簡単です。

Power Query

このお題では他に簡単な方法があるので少々面倒な気がしますので割愛します。

UNIQUE関数

これが使えるなら（現時点で365なら）、これが最も簡単です。

サイト内関連ページ

第88回．並べ替え（Sort）｜VBA入門

・Range.Sortメソッド・・・Excel2003までのソート・2007以降の並べ替え・Excel2003までのSortとExcel2007以降のSortの使い分け

第89回．オートフィルタ（AutoFilter）｜VBA入門

・Range.AutoFilterメソッド・AutoFilterModeプロパティ・AutoFilterオブジェクト・オートフィルタのVBA使用例・日付のフィルタ・オートフィルタまとめ

第90回．フィルタオプションの設定（AdvancedFilter）｜VBA入門

・フィルター詳細設定の使い方・Range.AdvancedFilter メソッド・フィルターオプションの設定の関連記事

第93回．ピボットテーブル（PivotTable）｜VBA入門

・ピボットテーブル（PivotTable）を構成するオブジェクト群・Excel2010のピボットテーブル（PivotTable）のマクロ記録・Excel2003のピボットテーブル（PivotTable）のマクロ記録・Excel2010とExcel2003のピボットテーブルVBAの違いについて・ピボットテーブル（PivotTable）のマクロVBA実践例

第132回．その他のExcel機能（グループ化、重複の削除、オートフィル等）｜VBA入門

・マクロの記録・グループ化・重複の削除・オートフィル・連続データの作成・その他のExcel機能

重複削除しユニークデータ作成（フィルターオプションの設定）｜エクセルの基本操作

エクセル作業においては、データの重複を排除して、ユニークなデータを作成する必要がある場合は多々あります。そのような時の操作として、以下の方法があります。・COUNTIF関数で重複を判定して削除・ピボットテーブルで重複を削除・重複の削除で重複を削除・フィルタの詳細設定(フィルターオプションの設定)で重複を削除 …

同じテーマ「VBA100本ノック」の記事

14本目：社外秘シート削除
 15本目：シートの並べ替え
 16本目：無駄な改行を削除
17本目：重複削除（ユニーク化）
18本目：名前定義の削除
 19本目：図形のコピー
 20本目：ブックのバックアップ
 21本目：バックアップファイルの削除
 22本目：FizzBuzz発展問題
 23本目：シート構成の一致確認
 24本目：全角英数のみ半角

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.RangeとCellsの使い方｜VBA入門
5.繰り返し処理（For Next)｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.メッセージボックス(MsgBox関数)｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
17本目：重複削除（ユニーク化）

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック 17本目：重複削除（ユニーク化）