VBA 重複チェック　～チェック項目が1つの場合、複数項目の場合～

ここのところ諸事情でブログを更新出来ていなかったので久々のエントリーになります。
今回はExcelで重複登録を防ぐためのVBAをアップしたいと思います。

住所録などのリストを作成する際、同一のデータ入力は避けたいものですがデータ量が多くなると目視でのチェックはほぼ不可能になります。そんな時に利用したいのがVBAによる重複チェック機能です。

今回のサンプルではCountIf関数とFindメソッドを使って単一条件と複数条件による重複チェックを行う方法を2通り紹介します。

重複チェック1：チェック項目が1つの場合

まずはIDやコードなどユニークにしなければいけない項目の重複チェックについて説明します。
CountIf関数を使って同一IDをカウントして2件以上ある場合はメッセージを表示します。

CountIf関数を使ったVBAサンプル

VBE(Visual Basic Editor)を起動してシート[Sheet1]の変更時のVBAを以下の通り作成します。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wCellVal As String
Dim wLastGyou As Long
Dim Obj As Object
Dim wFirstCell As Object

With Worksheets("Sheet1")

    '最終行番号を取得
    wLastGyou = .UsedRange.Rows.Count
        
    'セルの値を取得する
    wCellVal = .Cells(Target.Row, Target.Column).Value
    
    
    'A列(ID)の重複チェックを行う
    If Target.Column = 1 Then
        If Application.CountIf(.Range("A2:A" & wLastGyou), wCellVal) > 1 Then
            MsgBox "IDが重複しています。", vbOKOnly + vbExclamation, "入力エラー"
            Exit Sub
        End If
    End If
    
End With
    
End Sub

VBAコードの解説

列の判定

まずは、それぞれの入力チェック処理の先頭で　If Target.Column = 1 Then　を使って対象列（A列）の判定を行っています。入力したセルがA列の場合は次の処理に進みます。※16行目

CountIf関数

CountIf関数を使って重複チェックを実行します。カウントが2件以上の場合はエラーメッセージを表示します。※17～20行目

If Application.CountIf(.Range("A2:A" & wLastGyou), wCellVal) > 1 Then
    MsgBox "IDが重複しています。", vbOKOnly + vbExclamation, "入力エラー"
    Exit Sub
End If

尚、CountIf関数の使い方は以下の通りです。
COUNTIF(範囲,検索条件)

重複チェック1：チェック項目が複数の場合

2つ目の方法は複数の条件を使った重複チェックの方法です。色々な手法はあるかと思いますが今回はFindメソッドを使った方法を紹介します。
以下のような住所録の場合、名前と住所が同じ場合は重複として扱いたい場合などがあります。このような複数の条件で重複チェックする方法をFindメソッドをつかって行いたいと思います。

Findメソッドを使ったVBAサンプル

先ほどと同様にVBE(Visual Basic Editor)を起動してシート[Sheet1]の変更時のVBAを以下の通り作成します。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wLastGyou As Long
Dim Obj As Object
Dim wFirstCell As Object

With Worksheets("Sheet1")

    '最終行番号を取得
    wLastGyou = .UsedRange.Rows.Count
        
    '名前(B列)＆住所(C列)の重複チェックを行う
    If Target.Column = 2 Or Target.Column = 3 Then
    
        'B列のセルが未入力の場合は処理を中止する
        If .Range("B" & Target.Row).Value = "" Then Exit Sub
                    
        'B列を検索
        Set Obj = .Range("B2:B" & wLastGyou).Find( _
                            What:=Range("B" & Target.Row).Value, _
                            After:=Range("B" & Target.Row), _
                            LookIn:=xlValues, _
                            Lookat:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False, _
                            MatchByte:=False)
        
        '検索対象がない場合は処理を行わない
        If Not Obj Is Nothing Then
        
            '最初に見つかったセルをオブジェクト変数に設定
            Set wFirstCell = Obj
        
            '繰り返し処理
            Do
                '入力したセルと検索されたセルのアドレスが異なる場合はC列をチェック
                If .Range("B" & Target.Row).Address <> Obj.Address Then
                    '入力したセルと検索されたセルのC列の値をチェックする
                    If Range("C" & Obj.Row).Value = Range("C" & Target.Row).Value Then
                        '重複したセルに移動
                        .Range("B" & Obj.Row & ":C" & Obj.Row).Select
                        MsgBox "同一データが存在しています。", _
                                vbOKOnly + vbExclamation, "入力エラー"
                        Exit Sub
                    End If
                End If
                
                '次の検索を行う
                Set Obj = .Range("B2:B" & wLastGyou).FindNext(Obj)
            
            ' 最初に検索されたセルに戻るまでループ
            Loop Until Obj.Address = wFirstCell.Address
            
        End If
                    
    End If

End With
    
End Sub