ExcelのVBAで重複をチェックする方法｜削除せずに重複行へ印を付け、件数と位置を一覧にする

顧客コードや伝票番号に重複がないかを確かめたいとき、いきなり削除してしまうと、どの行が消えたのか、本当に同じデータだったのかを後から確認できません。まずは元のデータを1行も消さずに、重複している行に印を付け、どのキーが何件、何行目にあるかを一覧にします。この記事では、そこまでをマクロで行う方法を紹介します。

このマクロでできること

例として、次のような「顧客一覧」シートがあるとします。1行目が見出しで、B列が顧客コードです。

マクロを実行すると、次の3つを出力します。

1. 判定列（この例ではH列）に「重複 1/2」「重複 2/2」のような印を書き込み、そのセルに色を付ける
2. 「重複一覧」シートに、重複しているキー・件数・行番号の一覧を作る
3. データ行数、重複しているキーの種類数、重複に含まれる行数をメッセージで表示する

マクロが書き込むのは、判定列と「重複一覧」シートだけです。元のデータのセルの値や色は変更しません。

コード

標準モジュールに貼り付けます。先頭の定数とシート名は、お使いの表に合わせて変更してください。

Option Explicit

Public Sub CheckDuplicates()
    Const SHEET_NAME As String = "顧客一覧"
    Const KEY_COL As Long = 2        ' キー列（B列）
    Const FLAG_COL As Long = 8       ' 判定を書き込む列（H列）
    Const HEADER_ROW As Long = 1     ' 見出し行
    Const FLAG_HEADER As String = "重複チェック"

    Dim ws As Worksheet, outWs As Worksheet
    Dim cnt As Object, rowsOf As Object, seen As Object
    Dim keys As Variant, flags() As Variant, key As Variant
    Dim firstRow As Long, lastRow As Long, n As Long
    Dim i As Long, r As Long
    Dim k As String
    Dim dupKeys As Long, dupRows As Long

    Set ws = ThisWorkbook.Worksheets(SHEET_NAME)
    firstRow = HEADER_ROW + 1
    lastRow = ws.Cells(ws.Rows.Count, KEY_COL).End(xlUp).Row
    If lastRow < firstRow Then
        MsgBox "データがありません。", vbExclamation
        Exit Sub
    End If
    n = lastRow - firstRow + 1

    ' 判定列に別のデータがあれば止める（前回の判定結果なら上書きする）
    If Application.WorksheetFunction.CountA(ws.Columns(FLAG_COL)) > 0 Then
        If ws.Cells(HEADER_ROW, FLAG_COL).Value <> FLAG_HEADER Then
            MsgBox "判定列にデータがあります。FLAG_COL を空いている列に変えてください。", vbExclamation
            Exit Sub
        End If
    End If

    ' キー列をまとめて配列に読み込む
    If n = 1 Then
        ReDim keys(1 To 1, 1 To 1)
        keys(1, 1) = ws.Cells(firstRow, KEY_COL).Value
    Else
        keys = ws.Range(ws.Cells(firstRow, KEY_COL), ws.Cells(lastRow, KEY_COL)).Value
    End If

    Set cnt = CreateObject("Scripting.Dictionary")
    Set rowsOf = CreateObject("Scripting.Dictionary")
    Set seen = CreateObject("Scripting.Dictionary")
    cnt.CompareMode = vbTextCompare      ' 大文字・小文字を同じキーとして扱う
    rowsOf.CompareMode = vbTextCompare
    seen.CompareMode = vbTextCompare

    ' 1回目：キーごとの件数と行番号を集める
    For i = 1 To n
        If Not IsError(keys(i, 1)) Then
            k = Trim$(CStr(keys(i, 1)))
            If Len(k) > 0 Then
                r = firstRow + i - 1
                If cnt.Exists(k) Then
                    cnt(k) = cnt(k) + 1
                    rowsOf(k) = rowsOf(k) & ", " & r
                Else
                    cnt.Add k, 1
                    rowsOf.Add k, CStr(r)
                End If
            End If
        End If
    Next i

    ' 2回目：行ごとの判定を作る
    ReDim flags(1 To n, 1 To 1)
    For i = 1 To n
        If IsError(keys(i, 1)) Then
            flags(i, 1) = "キーがエラー値"
        Else
            k = Trim$(CStr(keys(i, 1)))
            If Len(k) = 0 Then
                flags(i, 1) = "キー空白"
            ElseIf cnt(k) >= 2 Then
                If seen.Exists(k) Then
                    seen(k) = seen(k) + 1
                Else
                    seen.Add k, 1
                End If
                flags(i, 1) = "重複 " & seen(k) & "/" & cnt(k)
                dupRows = dupRows + 1
            Else
                flags(i, 1) = ""
            End If
        End If
    Next i

    ' 判定列を書き直す（判定列以外には書き込まない）
    ws.Columns(FLAG_COL).Clear
    ws.Cells(HEADER_ROW, FLAG_COL).Value = FLAG_HEADER
    ws.Cells(firstRow, FLAG_COL).Resize(n, 1).Value = flags
    For i = 1 To n
        If Left$(flags(i, 1), 2) = "重複" Then
            ws.Cells(firstRow + i - 1, FLAG_COL).Interior.Color = RGB(255, 235, 156)
        End If
    Next i

    ' 重複一覧シートを用意する
    On Error Resume Next
    Set outWs = ThisWorkbook.Worksheets("重複一覧")
    On Error GoTo 0
    If outWs Is Nothing Then
        Set outWs = ThisWorkbook.Worksheets.Add(After:=ws)
        outWs.Name = "重複一覧"
    Else
        outWs.Cells.Clear
    End If

    outWs.Columns(1).NumberFormat = "@"   ' 00123 のようなキーを文字列のまま書く
    outWs.Columns(3).NumberFormat = "@"
    outWs.Range("A1:C1").Value = Array("キー", "件数", "行番号")
    r = 2
    For Each key In cnt.Keys
        If cnt(key) >= 2 Then
            outWs.Cells(r, 1).Value = key
            outWs.Cells(r, 2).Value = cnt(key)
            outWs.Cells(r, 3).Value = rowsOf(key)
            r = r + 1
            dupKeys = dupKeys + 1
        End If
    Next key
    outWs.Columns("A:C").AutoFit

    MsgBox "データ行数: " & n & " 行" & vbCrLf & _
           "重複しているキー: " & dupKeys & " 種類" & vbCrLf & _
           "重複に含まれる行: " & dupRows & " 行", vbInformation
End Sub

実行前に確認すること

• 判定列は空いている列にする：判定列は毎回いったん消去してから書き直します。見出しが「重複チェック」以外の値が入っている列を指定した場合は、何も書き込まずに止まるようにしています。
• 「重複一覧」という名前のシートを別の用途で使っていないか：同じ名前のシートがあると、その中身を消去してから一覧を書き込みます。
• 最終行を判定する列：最終行はキー列の下から探しています。キー列の末尾に空欄がある場合は、その行が判定の対象から外れます。必ず値が入る列で lastRow を取るように変更してください。
• フィルターは解除しておく：絞り込んだ状態だと、最終行が正しく取れないことがあります。
• 件数が多い場合：数万行以上あると、色付けのループに時間がかかります。処理の先頭で Application.ScreenUpdating = False を指定し、最後に True に戻すと速くなります。

何を「同じキー」とみなすか

重複チェックの結果は、キーをどう比べるかで変わります。このコードの扱いと、変えたい場合の直し方は次のとおりです。

vbTextCompare で比較すると、日本語環境では大文字・小文字に加えて、全角・半角やひらがな・カタカナの違いも同じとみなされる場合があります。意図どおりに判定されるか、数行の見本データで先に確かめてください。比較方法を変える場合は、cnt・rowsOf・seen の3つの CompareMode を必ずそろえます。また、CompareMode はキーを追加する前に設定する必要があります。

比べ方を変えても、元のセルの値は変わりません。判定のときだけキーを整えている、という点を押さえておくと、削除や修正に進むときに迷いません。

複数の列を組み合わせてキーにする

「氏名と電話番号が両方同じ」「伝票番号と明細番号が同じ」のように、複数の列で判定したい場合は、2つ目の列も配列に読み込み、間に vbTab を挟んでつなげたものをキーにします。区切りを入れておかないと、AB + C と A + BC が同じキーになってしまいます。

    ' 読み込み部分：2つ目のキー列（例：D列）も配列に取る
    keys2 = ws.Range(ws.Cells(firstRow, 4), ws.Cells(lastRow, 4)).Value

    ' キーを作る2か所を、次のように置き換える
    k = Trim$(CStr(keys(i, 1))) & vbTab & Trim$(CStr(keys2(i, 1)))

組み合わせる場合は、次の箇所もあわせて直してください。

• keys2 を Variant で宣言し、データが1行だけのときの読み込みも keys と同じように分ける
• IsError の判定を2列分にする
• 空白の判定を Len(Replace(k, vbTab, "")) = 0 にする
• 一覧に書き出すときは、Replace(key, vbTab, " / ") のように見やすい区切りに置き換える

結果の確かめ方

出力された結果が正しいかは、次の手順で確かめます。

1. 件数の整合を見る：「重複一覧」シートの件数列の合計と、判定列で「重複」と付いた行の数が一致するかを確認します。たとえば =SUM(重複一覧!B:B) と =COUNTIF(顧客一覧!H:H,"重複*") を並べて比べます。
2. 実データを目で見る：一覧の行番号を見て元の行を開き、本当に同じ取引や同じ相手なのかを確認します。同じコードが別の相手に振られている、入力ミスで同じコードになった、といったケースは、削除ではなく修正の対象です。
3. 並べ替えのタイミングに注意する：重複した行を並べて見たいときは、判定列でフィルターをかけるのが安全です。表を並べ替えると行の位置が変わり、一覧の行番号と合わなくなります。並べ替えた場合は、マクロを実行し直してください。
4. データを直したら再実行する：判定列と一覧は実行した時点の結果です。データを修正したら、もう一度実行して最新の状態にします。

削除に進む前に決めておくこと

重複の一覧ができたら、すぐに消すのではなく、次の点を決めてから削除の作業に進みます。

• 重複したキーのうち、どの行を残すか（最初の行、日付が最新の行、金額などの項目が埋まっている行など）
• 残す行に、消す行の情報をまとめる必要がないか
• 削除前のブックをコピーとして保存したか

判定列と「重複一覧」を残しておけば、削除後に「何件消したか」「どのキーだったか」を後から説明できます。