EXCEL VBA 重複データをチェック・抽出・別シート・メッセージ・New Collection（テクニック）

2020年3月10日

EXCEL VBA 重複データをチェック・抽出・別シート・メッセージ（テクニック）

●はじめに

EXCELでデータの一覧表などを作成し、入力したデータに対して重複データをチェックし、別の列に一意の一覧表を作成したり、別のシートに作成する方法などを説明いたします。EXCELデータを目視で重複データをチェックするのは、データ件数が数百件・数千件となると目視では、困難なためVBAプログラムを使い、素早くかつ正確に作成する必要があります。下記にサンプルプログラムを３パターン作成しましたので、参考に利用して下さい。

●プログラム説明　サンプルプログラム①（重複データから一意データの抽出）

下記のプログラムは、同一列内の重複データから一意のデータを抽出するプログラムです。Sheet１のA列に業者名の重複データの一覧があります。その中から一意のデータをSheet１のE列に業者名の一覧を作成します。
※下記のプログラムは、シート名が、「Sheet１」で実行出来るように作成しています。他のシート名の場合は、エラーがは発生します。

Sub Jyuufuku01()

    Dim ws01 As Worksheet
    Dim HIKAKU As Range
    Dim KEN01, JYUUFUKU, i As Long
    
    Set ws01 = Worksheets("Sheet1") 'ワークシートの設定
    
    KEN01 = ws01.Cells(Rows.Count, "A").End(xlUp).Row        'A列の最終行を設定する
   
    JYUUFUKU = 2
    
    For i = 2 To KEN01
    
        Set HIKAKU = ws01.Columns("E").Find(What:=ws01.Cells(i, "A"), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                                                                  'A列とE列を比較する
            
            If HIKAKU Is Nothing Then                             '比較して無い場合は、下記を実行
                ws01.Cells(JYUUFUKU, "E") = ws01.Cells(i, "A")      '追加する文字を転記する。（コード）
                JYUUFUKU = JYUUFUKU + 1
                   
            End If
    Next i                                                        'A列データの最終行までループ
    
   
End Sub

Sub Jyuufuku01()

Dim ws01 As Worksheet

Dim HIKAKU As Range

Dim KEN01, JYUUFUKU, i As Long

Set ws01 = Worksheets("Sheet1") 'ワークシートの設定

KEN01 = ws01.Cells(Rows.Count, "A").End(xlUp).Row 'A列の最終行を設定する

JYUUFUKU = 2

For i = 2 To KEN01

Set HIKAKU = ws01.Columns("E").Find(What:=ws01.Cells(i, "A"), LookIn:=xlFormulas, _

LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

'A列とE列を比較する

If HIKAKU Is Nothing Then '比較して無い場合は、下記を実行

ws01.Cells(JYUUFUKU, "E") = ws01.Cells(i, "A") '追加する文字を転記する。（コード）

JYUUFUKU = JYUUFUKU + 1

End If

Next i 'A列データの最終行までループ

End Sub

●実行結果　サンプルプログラム①（実行後：A列の重複している業者名からE列に一意の業者名が表示されました。）

●プログラム説明　サンプルプログラム②（重複データから一意データの抽出）：New Collectionを使用した場合

下記のプログラムは、上記のプログラムと実行結果は、同じになりますが、New Collectionを使ったプログラムになります。処理内容は同じですが、同一列内の重複データから一意のデータを抽出するプログラムです。Sheet１のA列に業者名の重複データの一覧があります。その中から一意のデータをSheet１のE列に業者名の一覧を作成します。
※下記のプログラムは、シート名が、「Sheet１」で実行出来るように作成しています。他のシート名の場合は、エラーがは発生します。

Sub jyuufuku02()

    Dim Corp As New Collection
    Dim i, mRow As Long
    Dim ws01 As Worksheet
    
    Set ws01 = Worksheets("Sheet1") 'ワークシートの設定
    
    mRow = ws01.Cells(Rows.Count, "A").End(xlUp).Row 'A列の最終行を設定
        
        On Error Resume Next  'エラーが発生しても続行する。
            
            For i = 2 To mRow  'A列の最終行データまで繰り返す
                Corp.Add ws01.Cells(i, "A"), ws01.Cells(i, "A") 'コレクションに追記
            Next i
            
        On Error GoTo 0
        
            For i = 1 To Corp.Count   'コレクションデータ最終件数まで繰り返す
                ws01.Cells(i + 1, "E") = Corp(i)  'コレクションデータを順番に取り出す。
            Next i
End Sub

Sub jyuufuku02()

Dim Corp As New Collection

Dim i, mRow As Long

Dim ws01 As Worksheet

Set ws01 = Worksheets("Sheet1") 'ワークシートの設定

mRow = ws01.Cells(Rows.Count, "A").End(xlUp).Row 'A列の最終行を設定

On Error Resume Next 'エラーが発生しても続行する。

For i = 2 To mRow 'A列の最終行データまで繰り返す

Corp.Add ws01.Cells(i, "A"), ws01.Cells(i, "A") 'コレクションに追記

Next i

On Error GoTo 0

For i = 1 To Corp.Count 'コレクションデータ最終件数まで繰り返す

ws01.Cells(i + 1, "E") = Corp(i) 'コレクションデータを順番に取り出す。

Next i

End Sub

●実行結果　サンプルプログラム②（A列の重複データから一意データをE列に抽出）：New　Collectionを使った場合の結果

●プログラム説明　サンプルプログラム③（重複データから一意データの抽出し、別シートに転記）

下記のプログラムは、サンプルプログラム①・②と同じ様に、重複データから一意のデータを抽出するプログラムですが、シート結果を別シート（Sheet2）に一意のデータを表示させます。なお、元データ（Sheet1）については、重複データが分かる様に該当するセルの背景色が青色に塗りつぶしされます。処理後には、重複件数をメッセージボックスで表示させます。
※下記のプログラムは、シート名が、「Sheet１」と「Sheet2」で実行出来るように作成しています。他のシート名の場合は、エラーがは発生します。

Sub Jyuufuku03()

    Dim ws01, ws02 As Worksheet
    Dim HIKAKU As Range
    Dim KEN01, JYUUFUKU, JYUUFUKU_COUNT, i As Long
    
    Set ws01 = Worksheets("Sheet1") 'ワークシートの設定(元のデータ)
    Set ws02 = Worksheets("Sheet2") 'ワークシートの設定（結果）
    
    KEN01 = ws01.Cells(Rows.Count, "A").End(xlUp).Row        'A列の最終行を設定する
   
    JYUUFUKU = 2
    JYUUFUKU_COUNT = 0
    
    For i = 2 To KEN01
    
        Set HIKAKU = ws02.Columns("A").Find(What:=ws01.Cells(i, "A"), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                                                                  'シート１：A列とシート２：A列を比較する
            
            If HIKAKU Is Nothing Then                             '比較して無い場合は、下記を実行
                ws02.Cells(JYUUFUKU, "A") = ws01.Cells(i, "A")      '追加する文字を転記する。（コード）
                ws02.Cells(JYUUFUKU, "B") = ws01.Cells(i, "B")
                ws02.Cells(JYUUFUKU, "C") = ws01.Cells(i, "C")
                
                JYUUFUKU = JYUUFUKU + 1
            Else
                ws01.Range("A" & i & ":C" & i).Interior.ColorIndex = 41 '重複する該当セルを青で塗りつぶします。
                JYUUFUKU_COUNT = JYUUFUKU_COUNT + 1  '重複件数をカウントする
       
            End If
    Next i                                                        'A列データの最終行までループ
    
    MsgBox "重複した件数は" & JYUUFUKU_COUNT & "件です。"
    
End Sub