1. Home » 
2. Excel講座の総目次 » 
3. Excel VBA入門：目次 » 
4. 重複なしのデータを抽出するいろいろな方法

重複なしのデータを抽出するいろいろな方法:Excel VBA入門

• 1列に重複したデータがあり、重複なしのデータを取り出す各種方法を書いてみます。

2021/08/12

テストデータ　　　Topへ

• このページの各コードはSheet1のA列に重複したデータがあり、Sheet2へ各種方法で重複なしのデータとして抽出します。
• ここでは、処理速度が遅いものから順に書いています。
  • 単純なループ、配列によるループ、フィルタオプションの設定、Dictionaryの利用の例、といった順です。
• Sheet1のサンプルデータ(テストデータとして利用できるように表に書き出しています)
  

  みかん

  栗

  なし

  ぶどう

  うめ

  栗

  すいか

  みかん

  りんご

  ぶどう

  みかん

  柿

  りんご

  柿

• Sheet1の元のデータ
  
• 重複なしのデータ
  

For〜Nextで逐次チェックする方法　　　Topへ

• もっとも基本的な方法で重複しているか否かを逐次調べ重複がなかったらSheet2へ追加していきます。
  ここで書いている方法の中では最も時間がかかります。
• コード例
  

  Sub ループ() 　Dim lastRow1 As Long, lastRow2 As Long 　Dim i As Long, j As Long, myCnt As Long 　　　　With Worksheets("Sheet2") 　　　　　　.Range("A:A").ClearContents 　　　　　　.Range("A1") = Worksheets("Sheet1").Range("A1").Value 　　　　　　lastRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 　　　　　　For i = 2 To lastRow1 　　　　　　　　myCnt = 0 　　　　　　　　lastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row 　　　　　　　　For j = 1 To lastRow2 　　　　　　　　　　If .Cells(j, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value Then 　　　　　　　　　　　　Exit For 　　　　　　　　　　Else 　　　　　　　　　　　　myCnt = myCnt + 1 　　　　　　　　　　End If 　　　　　　　　Next j 　　　　　　　　If myCnt = lastRow2 Then 　　　　　　　　　　.Cells(lastRow2 + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value 　　　　　　　　End If 　　　　　　Next i 　　　　End With End Sub

データを配列に読み込んでFor〜Nextで逐次チェックする方法　　　Topへ

• 元のデータを配列(x)に読み込み、For〜Nextで逐次チェックします。
  配列でチェックしているため上の方法よりは短時間で処理できます。
• コード例
  

  Sub 配列() 　　Dim x, y 　　Dim myCnt As Long, myFlg As Boolean 　　Dim i As Long, j As Long 　　　　With Worksheets("Sheet1") 　　　　　　x = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)) 　　　　End　With 　　　　ReDim y(1 To UBound(x), 1 To 1) 　　　　y(1, 1) = x(1, 1) 　　　　myCnt = 1 　　　　For i = LBound(x) To UBound(x) 　　　　　　myFlg = False 　　　　　　For j = 1 To myCnt 　　　　　　　　If x(i, 1) = y(j, 1) Then myFlg = True: Exit For 　　　　　　Next j 　　　　　　If myFlg = False Then myCnt = myCnt + 1: y(myCnt, 1) = x(i, 1) 　　　　Next i 　　　　With　Worksheets("Sheet2") 　　　　　　.Range("C:C").ClearContents 　　　　　　.Range("C1").Resize(UBound(y), 1) = y 　　　　End With End Sub

フィルタオプションの設定を利用する　　　Topへ

• Excelの一般機能であるフィルタオプションの設定を利用します。
  フィルタオプションの設定では列見出しが必要ですので、仮の見出しを挿入して抽出後に削除しています。
  配列の方法より短時間で処理できます。
• コード例
  

  Sub myAd() 　　Dim rngData As Range, rngC As Range 　　With Worksheets("Sheet2") 　　　　.Range("E:E").ClearContents 　　　　.Range("E1").Delete xlUp 　　End With 　　With Worksheets("Sheet1") 　　　　.Range("A1").Insert xlDown 　　　　.Range("A1").Value = "見出し" 　　　　Set rngData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)) 　　　　Set rngC = Worksheets("Sheet2").Range("E1") 　　　　rngData.AdvancedFilter _ 　　　　　　Action:=xlFilterCopy, _ 　　　　　　CopyToRange:=rngC, _ 　　　　　　Unique:=True 　　　　.Range("A1").Delete xlUp 　　End With End Sub

• Sheet2のE1セルに「見出し」が挿入されます。
  

Dictionaryを利用する　　　Topへ

• Dictionaryオブジェクトを利用します。
  このページの中ではもっとも短時間で処理できます。
• コード例
  

  Sub myDic() 　　Dim myDic As Object, myKey As Variant 　　Dim c As Variant, varData As Variant 　　　　Set myDic = CreateObject("Scripting.Dictionary") 　　　　With Worksheets("Sheet1") 　　　　　　varData = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value 　　　　End With 　　　　For Each c In varData 　　　　　　If Not c = Empty Then 　　　　　　　　If Not myDic.Exists(c) Then 　　　　　　　　　　myDic.Add c, Null 　　　　　　　　End If 　　　　　　End If 　　　　Next ’データ数が65,000件といったような多量な場合はTransposeを使った書き出し方は避けてください。 　　　　myKey = myDic.Keys 　　　　With Worksheets("Sheet2") 　　　　　　.Range("G:G").ClearContents 　　　　　　.Range("G1").Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myKey) 　　　　End With 　　　　Set myDic = Nothing End Sub

• 上のコードをデータ数6万5000個以上で#N/Aエラーが返されるとの連絡がありました。(2021/8/11)
  原因は　Application.WorksheetFunction.Transpose　らしいなぁ・・・といった感じでした。
  そこで、配列にデータ myDic.keys を書き出して、この配列を一気にシートに書き出す方法に変えたところエラーを回避できました。
  

  myKey = myDic.keys 　Dim i As Long 　ReDim myE(1 To UBound(myKey) + 1, 1 To 1) As Variant 　　For i = 0 To UBound(myKey) 　　　myE(i + 1, 1) = myKey(i) 　　Next 　Worksheets("Sheet2").Cells(1, "H").Resize(UBound(myE, 1), UBound(myE, 2)).Value = myE Set myDic = Nothing

[重複の削除]機能を利用する　　　Topへ

• 「重複の削除(RemoveDuplicates)」を利用すると、最も簡単なコードになります。(記 2021/8/12)
  コードはSheet1のA列にあるデータをSheet4のC列にコピーします。
  Sheet4のC列にコピーしたデータを重複の削除の機能で重複のないデータにしています。
  

  Sub jyuufukunodskujyo() 　Dim lRow As Long 　lRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 　Worksheets("Sheet2").Range("J1:J" & lRow).Value = Worksheets("Sheet1").Range("A1:A" & lRow).Value 　Worksheets("Sheet2").Range("J1:J" & lRow).RemoveDuplicates Columns:=1, Header:=xlNo End Sub

UNIQUE関数を利用する　　　Topへ

• Microsoft365ではUnique関数が利用できます。
  

  Sub kansu2() 　Dim c As Variant, varData As Variant 　Dim Ans As Variant 　With Worksheets("Sheet1") 　　varData = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value 　End With 　Ans = WorksheetFunction.Unique(varData) 　Worksheets("Sheet2").Range("M1").Resize(UBound(Ans), 1).Value = Ans End Sub

スポンサードリンク

PageViewCounter
　
　Since2006/2/27