Excel VBA 逆引き集 | 重複検索

Excel VBA
スポンサーリンク

重複検索

重複は「あるかだけ確認」「場所を特定」「色付け」「抽出」「複数列での判定」まで用途が広い。初心者向けに、最短コードから業務で耐える安全テンプレ、爆速手法までまとめます。

方針の選び方

  • 最短で1列の重複を判定: COUNTIF（式）や WorksheetFunction.CountIf（VBA）
  • 大量データでも速く場所特定・抽出: Dictionary（キー存在チェックで O(1)）
  • 複数列の複合キーで判定: 連結キー（例：コード & “|” & 日付）
  • 色付け・抽出だけしたい: 条件付き書式・AutoFilter
  • ユニーク化して保存したい: AdvancedFilter（Unique）や辞書でユニーク書き出し

基本：COUNTIF（式）の最短テンプレ

Sub Duplicates_CountIfFormula()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Range("B2:B" & last).FormulaR1C1 = "=COUNTIF(C1,RC1)" 'A列を数える→B列に件数
    '重複だけ色付け
    Dim r As Range: Set r = Range("B2:B" & last)
    r.SpecialCells(xlCellTypeFormulas, 1).FormatConditions.Delete
    r.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=1"
    r.FormatConditions(1).Interior.Color = RGB(255, 235, 156)
End Sub
VB
  • ポイント:
    • 件数が2以上なら重複。 シンプルで学習に向く。
    • 式を使うため、再計算の負荷はあり。値化すれば軽くなる。

VBAで判定：WorksheetFunction.CountIf（未式で完結）

Sub Duplicates_CountIf_VBA()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim i As Long, cnt As Long
    For i = 2 To last
        cnt = Application.WorksheetFunction.CountIf(Range("A2:A" & last), Cells(i, "A").Value)
        Cells(i, "B").Value = cnt
        If cnt > 1 Then Cells(i, "A").Interior.Color = RGB(255, 200, 200)
    Next
End Sub
VB
  • ポイント:
    • 式不要。コードだけで「件数」列を作れる。
    • 行ごと呼ぶので大量データではやや遅い。辞書へ。

業務定番：Dictionaryで重複検出（爆速）

Sub Duplicates_Dictionary_Flag()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String

    Application.ScreenUpdating = False
    For i = 2 To last
        k = CStr(Cells(i, "A").Value)
        If dict.Exists(k) Then
            Cells(i, "B").Value = "重複"               '2回目以降を「重複」フラグ
            Cells(i, "A").Interior.Color = RGB(255, 200, 200)
        Else
            dict.Add k, True
            Cells(i, "B").Value = "初出"               '初出にフラグ
        End If
    Next
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 初出・重複を即時判定。 10万件超でも軽い。
    • 型揺れ対策: キーは CStr で文字列化。

複数列を条件にした重複判定（複合キー）

Sub Duplicates_MultiColumn_Key()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String

    'A:商品コード、B:日付 の組合せで重複判定
    For i = 2 To last
        key = CStr(Cells(i, "A").Value) & "|" & Format$(Cells(i, "B").Value, "yyyymmdd")
        If dict.Exists(key) Then
            Cells(i, "C").Value = "重複"
            Rows(i).Interior.Color = RGB(255, 235, 156)
        Else
            dict.Add key, True
            Cells(i, "C").Value = "初出"
        End If
    Next
End Sub
VB
  • ポイント:
    • 連結キーで複数列の重複も簡単に扱える。
    • 日付は Format で正規化するのが安全。

重複行を抽出シートへ書き出し（場所特定）

Sub Duplicates_ExtractRows()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String, out As Worksheet, outRow As Long
    Set out = Worksheets("抽出"): outRow = 2

    For i = 2 To last
        k = CStr(Cells(i, "A").Value)
        If dict.Exists(k) Then
            Rows(i).Copy Destination:=out.Rows(outRow)
            outRow = outRow + 1
        Else
            dict.Add k, True
        End If
    Next
End Sub
VB
  • ポイント:
    • 2回目以降を抽出すると「重複一覧」が簡単に作れる。
    • 初出だけ抽出したいなら条件を反転。

重複セルを全部色付け（FindAll型で列挙）

Sub Duplicates_ColorAll()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String

    For i = 2 To last
        k = CStr(Cells(i, "A").Value)
        If dict.Exists(k) Then Cells(i, "A").Interior.Color = RGB(255, 200, 200) Else dict.Add k, True
    Next
End Sub
VB
  • ポイント:
    • 2回目以降の「重複セル」を色付け。最初は色を付けないほうが見やすい。

ユニークだけ別列へ出力（重複を除外）

Sub Unique_WriteOut_Dictionary()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String, outRow As Long: outRow = 2

    For i = 2 To last
        k = CStr(Cells(i, "A").Value)
        If Not dict.Exists(k) Then
            dict.Add k, True
            Cells(outRow, "C").Value = k   'C列にユニーク一覧
            outRow = outRow + 1
        End If
    Next
End Sub
VB
  • ポイント:
    • ユニーク一覧の作成が一瞬でできる（AdvancedFilterの代替）。

AdvancedFilterでユニーク抽出（式不要の内蔵機能）

Sub Unique_AdvancedFilter()
    Dim rng As Range: Set rng = Range("A1").CurrentRegion
    rng.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
End Sub
VB
  • ポイント:
    • 内蔵ユニーク抽出。形式を保ちたいときや式を使いたくないときに。

安全テンプレ（前後の停止・復帰）

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

Sub Duplicates_SafeWrap_End()
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 大量処理が軽くなる。 失敗時も復帰するよう On Error を併用。

よくある落とし穴と対策

  • 先頭ゼロや型違いで「同じ値」が別扱いになる
    • 対策: キーは CStr で文字列化、必要なら Format で正規化（例：品番は Format$(val, "@") は不可なのでそのまま文字列に変換）。
  • 空白・改行混入で別値扱い
    • 対策: キー登録前に Trim と Replace(s, vbCrLf, "") などで清掃。
  • 複合キーの区切りが曖昧
    • 対策: 区切りは存在しない文字（例：”|”）を使う。日付は yyyymmdd へ統一。
  • 行ごとのセルアクセスで遅い
    • 対策: さらに高速化したい場合は範囲を配列へ読み込み→辞書処理→一括書き戻しにする。
  • 色付け・コピーが多すぎて遅い
    • 対策: まず対象セルを収集（Union）→一括で書式・コピーを適用。

例題で練習

'例1：A列で重複を検出し、B列へ「初出/重複」を出力
Sub Example_FlagDuplicates()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To last
        k = CStr(Cells(i, "A").Value)
        Cells(i, "B").Value = IIf(dict.Exists(k), "重複", "初出")
        If Not dict.Exists(k) Then dict.Add k, True
    Next
End Sub

'例2：A列+日付(B列)の複合キー重複を抽出シートへ
Sub Example_ExtractDuplicates_MultiKey()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String, out As Worksheet, outRow As Long
    Set out = Worksheets("抽出"): outRow = 2
    For i = 2 To last
        key = CStr(Cells(i, "A").Value) & "|" & Format$(Cells(i, "B").Value, "yyyymmdd")
        If dict.Exists(key) Then
            Rows(i).Copy Destination:=out.Rows(outRow)
            outRow = outRow + 1
        Else
            dict.Add key, True
        End If
    Next
End Sub

'例3：A列のユニーク一覧をD列へ（AdvancedFilter）
Sub Example_UniqueToD()
    With Range("A1").CurrentRegion.Columns(1)
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
    End With
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました