Excel VBA 逆引き集 | 重複チェック

Excel VBA
スポンサーリンク

重複チェック

重複は“気づかないうちに蓄積する”から厄介。だからこそ、初心者でも安心して使える「見える化」「抽出」「防止」のテンプレをまとめました。コツは「キーの正規化（Trim＋大文字化）」「配列＋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 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列の重複セルを黄色（1回以上の重複）に塗ります。見出しはA1。

Sub HighlightDuplicates_InColumn()
    SpeedOn
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String

    '一旦クリア
    ws.Range("A2:A" & lastRow).Interior.ColorIndex = xlNone

    For i = 2 To lastRow
        k = NormKey(ws.Cells(i, "A").Value)
        If Len(k) = 0 Then GoTo cont
        If dict.Exists(k) Then
            '今回と過去の出現を塗る
            ws.Cells(i, "A").Interior.Color = vbYellow
        Else
            dict(k) = i
        End If
cont:
    Next
    '過去分もまとめて塗る（任意・高速を重視するなら省略可）
    Dim key As Variant
    For Each key In dict.Keys
        If WorksheetFunction.CountIf(ws.Range("A2:A" & lastRow), key) > 1 Then
            ws.Cells(dict(key), "A").Interior.Color = vbYellow
        End If
    Next
    SpeedOff
    MsgBox "重複セルをハイライトしました。"
End Sub
VB
  • ポイント: 初回/2回目以降両方塗ると「重複箇所」が一目で分かる。

抽出：重複一覧を別シートへ出力（単一列）

A列の重複値と行番号を「重複一覧」へ出力します。

Sub ListDuplicates_InColumn()
    SpeedOn
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim hits As Object: Set hits = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String

    For i = 2 To lastRow
        k = NormKey(ws.Cells(i, "A").Value)
        If Len(k) = 0 Then GoTo cont
        If dict.Exists(k) Then
            '出現位置を蓄積
            hits(k) = hits(k) & IIf(hits.Exists(k), "," & i, i)
        Else
            dict(k) = True
            hits(k) = CStr(i)
        End If
cont:
    Next

    '2回以上の出現だけ抽出
    Dim outWs As Worksheet: Set outWs = EnsureSheet("重複一覧", True)
    outWs.Range("A1:C1").Value = Array("値", "出現回数", "行番号一覧")
    Dim r As Long: r = 2
    Dim key As Variant
    For Each key In hits.Keys
        Dim arr() As String: arr = Split(hits(key), ",")
        If UBound(arr) >= 1 Then
            outWs.Cells(r, 1).Value = key
            outWs.Cells(r, 2).Value = UBound(arr) + 1
            outWs.Cells(r, 3).Value = hits(key)
            r = r + 1
        End If
    Next
    outWs.Columns.AutoFit
    SpeedOff
    MsgBox "重複一覧を作成しました。"
End Sub
VB
  • ポイント: 行番号一覧を残すと位置特定が楽。

複数列で重複（複合キー）

「コード×日付」などの組み合わせで重複判定します。

Private Function BuildCompositeKey(ByVal code As Variant, ByVal ymd As Variant) As String
    Dim part2 As String
    If IsDate(ymd) Then part2 = Format$(CDate(ymd), "yyyy-mm-dd") Else part2 = CStr(ymd)
    BuildCompositeKey = NormKey(code) & "|" & UCase$(Trim$(part2))
End Function

Sub HighlightDuplicates_MultiColumns()
    SpeedOn
    Dim ws As Worksheet: Set ws = ActiveSheet
    '列想定：A=コード、B=日付
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ws.Range("A2:B" & lastRow).Interior.ColorIndex = xlNone

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To lastRow
        key = BuildCompositeKey(ws.Cells(i, "A").Value, ws.Cells(i, "B").Value)
        If Len(key) = 0 Then GoTo cont
        If dict.Exists(key) Then
            ws.Range("A" & i & ":B" & i).Interior.Color = vbYellow
            '元の行も塗っておきたい場合
            ws.Range("A" & dict(key) & ":B" & dict(key)).Interior.Color = vbYellow
        Else
            dict(key) = i
        End If
cont:
    Next
    SpeedOff
    MsgBox "複合キーの重複をハイライトしました。"
End Sub
VB
  • ポイント: 区切りは安全な文字（|）で連結。日付は yyyy-mm-dd に統一。

防止：入力時に重複を拒否（Worksheet_Change）

入力直後に同一値がある場合、赤塗り・メッセージで通知して元に戻す例。A列を監視。

'シートモジュール（監視したいシートのコードウィンドウ）に貼付
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo fin
    If Target.Columns.Count > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub 'A列のみ

    Application.EnableEvents = False

    Dim cell As Range
    For Each cell In Target.Cells
        Dim k As String: k = NormKey(cell.Value)
        If Len(k) = 0 Then GoTo cont
        Dim rng As Range: Set rng = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        If WorksheetFunction.CountIf(rng, cell.Value) > 1 Then
            cell.Interior.Color = vbRed
            MsgBox "重複を検知しました: " & cell.Value
            '任意：元値を消す（コメントアウトで通知のみ）
            'cell.Value = ""
        Else
            cell.Interior.ColorIndex = xlNone
        End If
cont:
    Next

fin:
    Application.EnableEvents = True
End Sub
VB
  • ポイント: イベント再帰防止のためEnableEvents=False/Trueを忘れない。

実務：重複行の安全削除（下から）

重複値が2回以上ある場合、“2回目以降”を削除してユニーク化します。A列対象。

Sub RemoveDuplicates_Safe()
    SpeedOn
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    Dim delRows As Collection: Set delRows = New Collection

    For i = 2 To lastRow
        k = NormKey(ws.Cells(i, "A").Value)
        If Len(k) = 0 Then GoTo cont
        If dict.Exists(k) Then
            delRows.Add i
        Else
            dict(k) = True
        End If
cont:
    Next

    '下から削除
    Dim r As Long
    For r = delRows.Count To 1 Step -1
        ws.Rows(delRows(r)).Delete
    Next
    SpeedOff
    MsgBox "重複削除完了: " & delRows.Count & "行"
End Sub
VB
  • ポイント: 上から削除すると行が詰まってズレます。必ず“下から”。

応用：複数列の重複を一覧出力

「コード×日付×枝番」などの3列複合キーに対応。

Sub ListDuplicates_MultiColumns()
    SpeedOn
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim pos As Object: Set pos = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String

    For i = 2 To lastRow
        key = NormKey(ws.Cells(i, "A").Value) & "|" & _
              NormKey(ws.Cells(i, "B").Value) & "|" & _
              NormKey(ws.Cells(i, "C").Value)
        If dict.Exists(key) Then
            pos(key) = pos(key) & "," & i
        Else
            dict(key) = True
            pos(key) = CStr(i)
        End If
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("複合重複一覧", True)
    wsOut.Range("A1:D1").Value = Array("複合キー", "出現回数", "行番号一覧", "例:コード|日付|枝番")
    Dim r As Long: r = 2
    Dim k As Variant
    For Each k In pos.Keys
        Dim arr() As String: arr = Split(pos(k), ",")
        If UBound(arr) >= 1 Then
            wsOut.Cells(r, 1).Value = k
            wsOut.Cells(r, 2).Value = UBound(arr) + 1
            wsOut.Cells(r, 3).Value = pos(k)
            wsOut.Cells(r, 4).Value = ""
            r = r + 1
        End If
    Next
    wsOut.Columns.AutoFit
    SpeedOff
    MsgBox "複合重複一覧を作成しました。"
End Sub
VB

例題で練習

'例1：A列の重複セルをハイライト
Sub Example_HighlightSingle()
    HighlightDuplicates_InColumn
End Sub

'例2：A列の重複一覧を作成（値・回数・行番号）
Sub Example_ListSingle()
    ListDuplicates_InColumn
End Sub

'例3：A×Bの複合キーで重複をハイライト
Sub Example_HighlightMulti()
    HighlightDuplicates_MultiColumns
End Sub

'例4：A列の重複行を安全に削除（2回目以降）
Sub Example_RemoveSafe()
    RemoveDuplicates_Safe
End Sub

'例5：A×B×Cの複合キー重複を一覧化
Sub Example_ListMulti()
    ListDuplicates_MultiColumns
End Sub
VB

実務の落とし穴と対策

  • 表記揺れで判定ミス: NormKey（Trim＋大文字化）を必ず使う。半角/全角混在なら置換も検討。
  • 空白やNULLの扱い: 空は重複と扱わないのが無難。必要なら条件分岐で “空は除外”。
  • 列順や見出しの変更: 列番号を固定せず、見出し検索（Find）で列を特定する運用に拡張可能。
  • 大量データで遅い: Range→配列化、Dictionaryで存在判定、SpeedOn/Offの3点セットで解決。

スポンサーリンク
タイトルとURLをコピーしました