Excel VBA 逆引き集 | キー重複の検出

Excel VBA
スポンサーリンク

キー重複の検出

「同じキーが二重に登録されていないか、素早く確実に見つけたい」——初心者でも安全に使える“キー重複検出”テンプレをまとめました。実務の定番は、配列＋Dictionaryで突合、正規化で表記揺れを吸収、結果は一括で見える化です。

使う前に決めること

  • キーの定義: 何が同じなら重複か（例：コードだけ、コード×日付、コード×枝番）。
  • 正規化ルール: 前後空白、大小文字、全角半角、日付の書式をどう揃えるか。
  • 出力方法: ハイライト・一覧・フラグ列・削除候補のいずれか（まずは一覧が安全）。

共通ユーティリティ（速度・正規化）

Option Explicit

Private Sub SpeedOn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function NormKey(ByVal v As Variant) As String
    ' 前後空白を除去＋大文字化（必要ならここで半角化や記号除去も）
    NormKey = UCase$(Trim$(CStr(v)))
End Function

Private Function NormDateText(ByVal v As Variant) As String
    ' yyyy-mm-dd の文字列に統一（文字列日付もCDateで変換を試みる）
    On Error Resume Next
    If IsDate(v) Or Len(CStr(v)) > 0 Then
        NormDateText = Format$(CDate(v), "yyyy-mm-dd")
    Else
        NormDateText = ""
    End If
    On Error GoTo 0
End Function

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function
VB
  • ポイント
    • 速度: 画面更新・イベント・計算を止めるだけで体感が大きく変わる。
    • 正規化: 重複判定前に必ずキーを統一。日付は文字列でも同じ書式に。

単一キーの重複検出（一覧出力）

A列の「コード」をキーに重複を検出し、「キー重複一覧」へ値・出現回数・行番号を出します。

Sub DetectKeyDuplicates_Single()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
    Dim pos As Object: Set pos = CreateObject("Scripting.Dictionary")

    Dim r As Long, k As String
    For r = 2 To lastRow
        k = NormKey(ws.Cells(r, "A").Value)
        If Len(k) = 0 Then GoTo cont
        If seen.Exists(k) Then
            pos(k) = pos(k) & "," & r
        Else
            seen(k) = True
            pos(k) = CStr(r)
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("キー重複一覧", True)
    out.Range("A1:C1").Value = Array("キー", "出現回数", "行番号一覧")

    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In pos.Keys
        Dim arr() As String: arr = Split(pos(key), ",")
        If UBound(arr) >= 1 Then
            out.Cells(i, 1).Value = key
            out.Cells(i, 2).Value = UBound(arr) + 1
            out.Cells(i, 3).Value = pos(key)
            i = i + 1
        End If
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "単一キーの重複検出が完了しました（" & i - 2 & "キー）"
End Sub
VB
  • 使い方のコツ
    • 空値は除外: キーなしの行は対象外にするのが安全。
    • 行番号一覧: 後で現場確認するときの説明が早い。

複合キーの重複検出（コード×日付）

A列=コード、B列=日付の組み合わせで重複を検出し、一覧を作ります。

Sub DetectKeyDuplicates_Composite_CodeDate()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
    Dim pos As Object: Set pos = CreateObject("Scripting.Dictionary")

    Dim r As Long, code As String, d As String, key As String
    For r = 2 To lastRow
        code = NormKey(ws.Cells(r, "A").Value)
        d = NormDateText(ws.Cells(r, "B").Value)
        If Len(code) = 0 Or Len(d) = 0 Then GoTo cont
        key = code & "|" & d
        If seen.Exists(key) Then
            pos(key) = pos(key) & "," & r
        Else
            seen(key) = True
            pos(key) = CStr(r)
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("キー重複一覧_複合", True)
    out.Range("A1:D1").Value = Array("コード", "日付", "出現回数", "行番号一覧")

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In pos.Keys
        Dim arrKey() As String: arrKey = Split(CStr(k), "|")
        Dim arrPos() As String: arrPos = Split(pos(k), ",")
        If UBound(arrPos) >= 1 Then
            out.Cells(i, 1).Value = arrKey(0)
            out.Cells(i, 2).Value = arrKey(1)
            out.Cells(i, 3).Value = UBound(arrPos) + 1
            out.Cells(i, 4).Value = pos(k)
            i = i + 1
        End If
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "複合キー（コード×日付）の重複検出が完了しました（" & i - 2 & "組）"
End Sub
VB
  • 使い方のコツ
    • 区切りは安全な文字: 「|」を推奨。値内に含まれないものを選ぶ。
    • 日付は統一: yyyy-mm-dd の文字列に揃えると誤判定が減る。

結果の見える化：重複行を色でハイライト

検出結果の行番号を使って元データを塗ります。赤＝重複行（2回目以降）。

Sub HighlightDuplicateRows_FromList()
    SpeedOn

    Dim wsData As Worksheet: Set wsData = Worksheets("Data")
    Dim wsList As Worksheet: Set wsList = Worksheets("キー重複一覧")

    Dim lastRow As Long: lastRow = wsList.Cells(wsList.Rows.Count, "C").End(xlUp).Row
    Dim r As Long

    ' 既存色クリア（必要に応じて範囲調整）
    wsData.Cells.Interior.ColorIndex = xlNone

    For r = 2 To lastRow
        Dim s As String: s = CStr(wsList.Cells(r, 3).Value) ' 行番号一覧（例: "5,12,40"）
        If Len(s) = 0 Then GoTo cont
        Dim parts() As String: parts = Split(s, ",")
        Dim i As Long
        ' 1件目は「元行」なので塗らない、2件目以降を塗る
        For i = LBound(parts) + 1 To UBound(parts)
            Dim rowNum As Long: rowNum = CLng(parts(i))
            wsData.Rows(rowNum).Interior.Color = RGB(255, 200, 200)
        Next
cont:
    Next

    SpeedOff
    MsgBox "重複行をハイライトしました（2回目以降を赤）"
End Sub
VB
  • 使い方のコツ
    • 塗り分け: 初回は塗らず、2回目以降だけ塗ると原因箇所が分かる。
    • 候補→適用: 色で確認→承認→削除（必要なら）に繋げやすい。

フラグ列でマーク（削除せず“重複”と書く）

A列のキー重複を判定し、B列に「重複」と表示。後工程のフィルタに便利。

Sub FlagDuplicateKeys_InColumn()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
    ws.Range("B2:B" & lastRow).ClearContents

    Dim r As Long, k As String
    For r = 2 To lastRow
        k = NormKey(ws.Cells(r, "A").Value)
        If Len(k) = 0 Then GoTo cont
        If seen.Exists(k) Then
            ws.Cells(r, "B").Value = "重複"
        Else
            seen(k) = True
            ws.Cells(r, "B").Value = "" ' ユニーク
        End If
cont:
    Next

    SpeedOff
    MsgBox "重複フラグをB列に付けました"
End Sub
VB
  • 使い方のコツ
    • 非破壊: データは消さず、後でフィルタやピボットに掛けられる。

削除候補のプレビュー（2回目以降を出力）

いきなり消さず、まず「何を消すか」を出力して確認→承認後に削除する運用。

Sub PreviewDuplicateRemoval_Candidates()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
    Dim delRows As Collection: Set delRows = New Collection

    Dim r As Long, k As String
    For r = 2 To lastRow
        k = NormKey(ws.Cells(r, "A").Value)
        If Len(k) = 0 Then GoTo cont
        If seen.Exists(k) Then delRows.Add r Else seen(k) = True
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("重複削除候補", True)
    out.Range("A1:B1").Value = Array("行番号", "キー")
    Dim i As Long: i = 2
    Dim x As Long
    For x = 1 To delRows.Count
        r = delRows(x)
        out.Cells(i, 1).Value = r
        out.Cells(i, 2).Value = NormKey(ws.Cells(r, "A").Value)
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "重複削除候補を作成しました（" & delRows.Count & "行）"
End Sub
VB
  • 使い方のコツ
    • 下から削除: 実際に削除するときは、候補行を下から処理すること。

よくある落とし穴と対策

  • 落とし穴: 表記揺れで“別物”と判定される
    • 対策: NormKeyでTrim＋大文字化。必要なら半角化（StrConv）や記号除去も追加。
  • 落とし穴: 日付が文字列と数値で混在
    • 対策: NormDateTextでyyyy-mm-ddに統一。CDateで変換を試みる。
  • 落とし穴: 範囲が途中で切れて検出漏れ
    • 対策: CurrentRegionや最終行取得で“データの端”まで確実に処理。
  • 落とし穴: いきなり削除して後悔
    • 対策: 必ず「一覧（プレビュー）→承認→削除」の2段階。バックアップも習慣化。

例題で練習

'例1：単一キーの重複一覧を作る
Sub Example_DetectSingle()
    DetectKeyDuplicates_Single
End Sub

'例2：コード×日付の複合キーで重複一覧
Sub Example_DetectComposite()
    DetectKeyDuplicates_Composite_CodeDate
End Sub

'例3：重複行を赤でハイライト
Sub Example_HighlightRows()
    HighlightDuplicateRows_FromList
End Sub

'例4：B列に「重複」フラグを付ける
Sub Example_FlagColumn()
    FlagDuplicateKeys_InColumn
End Sub

'例5：削除候補のプレビューを作る
Sub Example_PreviewDelete()
    PreviewDuplicateRemoval_Candidates
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました