Excel VBA 逆引き集 | 重複除去

Excel VBA

2025.12.11

重複除去
基本の考え方
テンプレ1：標準機能で重複除去（最速）
テンプレ2：複数列を基準に重複除去
テンプレ3：辞書を使ってユニーク化（柔軟）
テンプレ4：重複を削除せず「ユニーク一覧」を作る
例題で練習
初心者向けポイント

重複除去

Excelで「同じ値が何度も出てくるので1つにしたい」「重複行を消したい」という場面はよくあります。初心者でも安心して使えるように、重複除去の定番テンプレをまとめました。

基本の考え方

対象列を決める: どの列で重複を判定するか。
残すルール: 先頭を残す／最新を残す／ユニークだけ残す。
方法:
- Excel標準機能 .RemoveDuplicates を使う（最速）。
- VBAで辞書（Dictionary）を使ってユニーク化する（柔軟）。

テンプレ1：標準機能で重複除去（最速）

Sub RemoveDuplicates_BuiltIn()
    Dim ws As Worksheet: Set ws = Worksheets("Data")
    With ws.Range("A1").CurrentRegion
        ' A列を基準に重複除去（見出しあり）
        .RemoveDuplicates Columns:=1, Header:=xlYes
    End With
    MsgBox "A列の重複を削除しました（先頭を残す）"
End Sub

Sub RemoveDuplicates_BuiltIn()
    Dim ws As Worksheet: Set ws = Worksheets("Data")
    With ws.Range("A1").CurrentRegion
        ' A列を基準に重複除去（見出しあり）
        .RemoveDuplicates Columns:=1, Header:=xlYes
    End With
    MsgBox "A列の重複を削除しました（先頭を残す）"
End Sub

ポイント: .RemoveDuplicates は一瞬で処理できる。
Columns:=1 → A列を基準に判定。複数列なら Array(1,2) のように指定。
Header:=xlYes → 1行目は見出しとして扱う。

テンプレ2：複数列を基準に重複除去

Sub RemoveDuplicates_MultiColumn()
    Dim ws As Worksheet: Set ws = Worksheets("Data")
    With ws.Range("A1").CurrentRegion
        ' A列とB列の組み合わせで重複判定
        .RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With
    MsgBox "A列×B列の重複を削除しました"
End Sub

Sub RemoveDuplicates_MultiColumn()
    Dim ws As Worksheet: Set ws = Worksheets("Data")
    With ws.Range("A1").CurrentRegion
        ' A列とB列の組み合わせで重複判定
        .RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With
    MsgBox "A列×B列の重複を削除しました"
End Sub

ポイント: 複合キー（コード×日付など）で重複判定できる。

テンプレ3：辞書を使ってユニーク化（柔軟）

Sub RemoveDuplicates_Dictionary()
    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 r As Long, key As String
    Dim delRows As Collection: Set delRows = New Collection

    For r = 2 To lastRow
        key = UCase$(Trim$(CStr(ws.Cells(r, "A").Value)))
        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

    MsgBox "A列の重複を削除しました（先頭を残す）"
End Sub

Sub RemoveDuplicates_Dictionary()
    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 r As Long, key As String
    Dim delRows As Collection: Set delRows = New Collection

    For r = 2 To lastRow
        key = UCase$(Trim$(CStr(ws.Cells(r, "A").Value)))
        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

    MsgBox "A列の重複を削除しました（先頭を残す）"
End Sub

ポイント:
- Trim＋UCaseで表記揺れを吸収。
- 削除は必ず「下から」。上から削除すると行番号がズレる。
- 柔軟に複合キーや条件付き削除に拡張できる。

テンプレ4：重複を削除せず「ユニーク一覧」を作る

Sub UniqueList_FromColumn()
    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 r As Long, key As String
    For r = 2 To lastRow
        key = UCase$(Trim$(CStr(ws.Cells(r, "A").Value)))
        If Len(key) > 0 Then dict(key) = True
    Next

    Dim wsOut As Worksheet: Set wsOut = Worksheets.Add
    wsOut.Range("A1").Value = "ユニーク一覧"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In dict.Keys
        wsOut.Cells(i, 1).Value = k
        i = i + 1
    Next

    MsgBox "ユニーク一覧を作成しました"
End Sub

Sub UniqueList_FromColumn()
    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 r As Long, key As String
    For r = 2 To lastRow
        key = UCase$(Trim$(CStr(ws.Cells(r, "A").Value)))
        If Len(key) > 0 Then dict(key) = True
    Next

    Dim wsOut As Worksheet: Set wsOut = Worksheets.Add
    wsOut.Range("A1").Value = "ユニーク一覧"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In dict.Keys
        wsOut.Cells(i, 1).Value = k
        i = i + 1
    Next

    MsgBox "ユニーク一覧を作成しました"
End Sub

ポイント: 重複を消さずに「抽出条件リスト」として使える。

例題で練習

'例1：A列の重複を標準機能で削除
Sub Example_BuiltIn()
    RemoveDuplicates_BuiltIn
End Sub

'例2：A×B列の複合キーで重複削除
Sub Example_Multi()
    RemoveDuplicates_MultiColumn
End Sub

'例3：辞書を使って柔軟に重複削除
Sub Example_Dict()
    RemoveDuplicates_Dictionary
End Sub

'例4：ユニーク一覧を作成
Sub Example_Unique()
    UniqueList_FromColumn
End Sub

'例1：A列の重複を標準機能で削除
Sub Example_BuiltIn()
    RemoveDuplicates_BuiltIn
End Sub

'例2：A×B列の複合キーで重複削除
Sub Example_Multi()
    RemoveDuplicates_MultiColumn
End Sub

'例3：辞書を使って柔軟に重複削除
Sub Example_Dict()
    RemoveDuplicates_Dictionary
End Sub

'例4：ユニーク一覧を作成
Sub Example_Unique()
    UniqueList_FromColumn
End Sub