Excel VBA 逆引き集 | 重複行の削除

Excel VBA
スポンサーリンク

重複行の削除

重複行は「見つける→方針を決める→安全に削除」の3ステップ。初心者でも失敗しないように、最短のやり方から柔軟な実務向けまでをテンプレでまとめます。

方針の決め方

  • 基準列（キー）: 何が同じなら「重複」かを決める（例：コードだけ、コード×日付の組）。
  • 残す・消すルール: 先頭を残すか、末尾を残すか、最新日付を残すか（ここが肝）。
  • 安全策: 下から削除、バックアップ作成、プレビューで確認。

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

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
  • 速度: 画面更新・イベント・計算停止→最後に戻す。
  • 正規化: 余計な空白や大小文字の違いで誤判定しない。
  • 安全な出力先: 重複一覧やバックアップを簡単に作れる。

最短テンプレ：標準機能で重複行削除（RemoveDuplicates）

見出しありの表で、A列（コード）を基準に重複を削除。先頭行だけ残ります。

Sub RemoveDuplicates_ByBuiltIn()
    SpeedOn
    With Worksheets("Data").Range("A1").CurrentRegion
        .RemoveDuplicates Columns:=1, Header:=xlYes
    End With
    SpeedOff
    MsgBox "RemoveDuplicatesで重複削除しました（先頭を残す）"
End Sub
VB
  • ポイント
    • 超高速・超簡単: 列指定だけで一瞬。
    • 複合キー: Columns:=Array(1,2) のように複数列指定可。
    • 先頭優先: 標準機能は「先にある行を残す」動き。

柔軟テンプレ：辞書で2回目以降を安全に削除（単一キー）

A列（コード）で、2回目以降を削除します。削除は必ず「下から」。

Sub RemoveDuplicates_SafeDownward()
    SpeedOn

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

    Dim dict As Object: Set dict = 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 dict.Exists(k) Then
            delRows.Add r
        Else
            dict(k) = True
        End If
cont:
    Next

    For r = delRows.Count To 1 Step -1
        ws.Rows(delRows(r)).Delete
    Next

    SpeedOff
    MsgBox "重複削除完了: " & delRows.Count & "行（2回目以降を削除）"
End Sub
VB
  • ポイント
    • 削除は下から: 上から削除は行番号ズレの元。
    • 空値は除外: 空白行は削除対象から外すのが無難。

複合キー版：コード×日付で重複削除

コードと日付が同じ行を重複とみなし、先に出てきたものを残します。

Private Function BuildKey2(ByVal v1 As Variant, ByVal v2 As Variant) As String
    Dim p2 As String
    If IsDate(v2) Then p2 = Format$(CDate(v2), "yyyy-mm-dd") Else p2 = CStr(v2)
    BuildKey2 = NormKey(v1) & "|" & UCase$(Trim$(p2))
End Function

Sub RemoveDuplicates_Composite()
    SpeedOn

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

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

    Dim r As Long, key As String
    For r = 2 To lastRow
        key = BuildKey2(ws.Cells(r, "A").Value, ws.Cells(r, "B").Value) 'A=コード, B=日付
        If Len(key) = 0 Then GoTo cont
        If dict.Exists(key) Then
            delRows.Add r
        Else
            dict(key) = True
        End If
cont:
    Next

    Dim i As Long
    For i = delRows.Count To 1 Step -1
        ws.Rows(delRows(i)).Delete
    Next

    SpeedOff
    MsgBox "複合キー重複削除完了: " & delRows.Count & "行"
End Sub
VB
  • ポイント
    • 区切り文字: 「|」を使うと安全。
    • 日付統一: yyyy-mm-dd で表記揺れ防止。

実務向け：最新日付だけ残して重複削除（コードごと）

「同じコードに複数の日付があるとき、最新だけ残す」ルールに対応。

Sub RemoveDuplicates_KeepLatestDate()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion '見出し: A=コード, B=日付, 他項目
    Dim v As Variant: v = rg.Value

    Dim cCode As Long: cCode = 1
    Dim cDate As Long: cDate = 2

    'コードごとの最新日付を記録
    Dim latest As Object: Set latest = CreateObject("Scripting.Dictionary")
    Dim r As Long, code As String, dt As Date
    For r = 2 To UBound(v, 1)
        code = NormKey(v(r, cCode))
        If Len(code) = 0 Or Not IsDate(v(r, cDate)) Then GoTo cont
        dt = CDate(v(r, cDate))
        If Not latest.Exists(code) Or dt > latest(code) Then latest(code) = dt
cont:
    Next

    '最新以外を削除リストへ（下から削除）
    Dim delRows As Collection: Set delRows = New Collection
    For r = 2 To UBound(v, 1)
        code = NormKey(v(r, cCode))
        If Len(code) = 0 Or Not IsDate(v(r, cDate)) Then GoTo cont2
        If CDate(v(r, cDate)) < latest(code) Then delRows.Add rg.Row + r - 1
cont2:
    Next

    Dim i As Long
    For i = delRows.Count To 1 Step -1
        ws.Rows(delRows(i)).Delete
    Next

    SpeedOff
    MsgBox "最新日付を残して重複削除: " & delRows.Count & "行"
End Sub
VB
  • ポイント
    • ルールを明確化: “最新だけ残す”が現場で一番揉めない。
    • 見出し位置が違う場合: Findで列特定に置き換えると頑健。

プレビュー付き：削除前に重複一覧を出す

いきなり消さず「何が消えるのか」を一覧化→承認→削除する2段階運用。

Sub Preview_Duplicates()
    SpeedOn

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

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim dup As Object: Set dup = 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 dict.Exists(k) Then
            dup(k) = dup(k) & IIf(Len(dup(k)) > 0, "," & r, r)
        Else
            dict(k) = True
            dup(k) = ""
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("重複削除候補", True)
    out.Range("A1:C1").Value = Array("値", "出現回数", "削除候補行（2回目以降）")

    Dim rr As Long: rr = 2
    Dim key As Variant
    For Each key In dup.Keys
        If Len(dup(key)) > 0 Then
            Dim arr() As String: arr = Split(dup(key), ",")
            out.Cells(rr, 1).Value = key
            out.Cells(rr, 2).Value = UBound(arr) + 2 '先頭＋候補数
            out.Cells(rr, 3).Value = dup(key)
            rr = rr + 1
        End If
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "削除候補を作成しました（重複削除前の確認用）"
End Sub
VB
  • ポイント
    • 安心運用: 「候補→適用」で誤削除リスクを下げる。
    • 承認フロー: 候補シートの行番号で合意してから、削除マクロを実行。

応用：重複を消さずにユニーク一覧を作る（元表は保持）

「ユニーク行だけ別シートへ抽出」する安全版。

Sub ExtractUniqueRows()
    SpeedOn

    Dim rg As Range: Set rg = Worksheets("Data").Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim out As Worksheet: Set out = EnsureSheet("ユニーク一覧", True)

    Dim r As Long, k As String, outRow As Long: outRow = 1
    'ヘッダー
    out.Range("A1").Resize(1, UBound(v, 2)).Value = Application.Index(v, 1, 0)
    outRow = 2

    For r = 2 To UBound(v, 1)
        k = NormKey(v(r, 1)) '基準列を必要に応じて変更
        If Len(k) = 0 Then GoTo cont
        If Not dict.Exists(k) Then
            out.Range("A" & outRow).Resize(1, UBound(v, 2)).Value = Application.Index(v, r, 0)
            dict(k) = True
            outRow = outRow + 1
        End If
cont:
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "ユニーク一覧を作成しました（元表は変更なし）"
End Sub
VB
  • ポイント
    • 非破壊: 元データは触らないので安全。
    • 後工程: ユニーク一覧を使ってレポートや再取込がしやすい。

よくある落とし穴と対策

  • 上から削除でズレる
    • 対策: 必ず「削除リスト→下から削除」。
  • 表記揺れで重複判定ミス
    • 対策: 先にNormKeyで正規化（Trim＋大文字化）。必要なら半角/全角の統一。
  • 日付の文字列・数値混在
    • 対策: 比較前にCDate＋Format("yyyy-mm-dd")で統一。
  • 列順が変わる現場
    • 対策: 固定列番号ではなく、見出し検索（Find）で列特定に拡張。
  • いきなり削除が怖い
    • 対策: 「プレビュー→適用」の2段階差分運用を採用。バックアップも習慣化。

例題で練習

'例1：標準機能で重複削除（先頭を残す）
Sub Example_BuiltIn()
    RemoveDuplicates_ByBuiltIn
End Sub

'例2：辞書で2回目以降を安全に削除（単一キー）
Sub Example_SafeDownward()
    RemoveDuplicates_SafeDownward
End Sub

'例3：コード×日付の複合キーで重複削除
Sub Example_Composite()
    RemoveDuplicates_Composite
End Sub

'例4：最新日付だけ残す重複削除（コードごと）
Sub Example_KeepLatest()
    RemoveDuplicates_KeepLatestDate
End Sub

'例5：削除前に重複候補をプレビュー
Sub Example_Preview()
    Preview_Duplicates
End Sub

'例6：ユニーク行だけ別シートへ抽出
Sub Example_ExtractUnique()
    ExtractUniqueRows
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました