Excel VBA 逆引き集 | UNIQUE化

Excel VBA
スポンサーリンク

UNIQUE化

重複でぐちゃっとした表を、すっきり「一意（ユニーク）」に整えるテンプレをまとめました。壊さずに抽出する安全版から、爆速で処理する実務版まで、初心者でも迷わないように段階別で解説します。

目的別の選び方

  • 最短で消して整える: RemoveDuplicates（元表を書き換える、先頭を残す）
  • 元表を残して抽出したい: Dictionaryでユニーク行を別シートへ
  • Excel 365/2021なら超手軽: WorksheetFunction.Uniqueで一瞬抽出
  • 複合キーでユニーク化: コード×日付など複数列の組み合わせで重複排除

最短テンプレ：標準機能でUNIQUE化（元表を整える）

「見出しありの表」を対象に、指定列で重複を削除します。先にある行を残します。

Sub Unique_ByBuiltIn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    With Worksheets("Data").Range("A1").CurrentRegion
        ' 単一列（A列=1）でユニーク化
        .RemoveDuplicates Columns:=1, Header:=xlYes

        ' 複合キー（AとBでユニーク化する例）
        ' .RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "RemoveDuplicatesでユニーク化が完了（先頭行を残す）"
End Sub
VB
  • 向いている場面: 元表を書き換えてOK、列が確定している、最速で終わらせたいとき。
  • 注意点: 「先頭を残す」挙動。残すルールを変えたいなら次のテンプレへ。

安全テンプレ：元表は触らずユニーク抽出（Dictionary）

基準列でユニーク行だけを別シートに出力します。元表はそのまま。

Sub Unique_Extract_SingleKey()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    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 wsOut As Worksheet: Set wsOut = EnsureSheet("ユニーク一覧", True)

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

    Dim r As Long, k As String
    For r = 2 To UBound(v, 1)
        k = UCase$(Trim$(CStr(v(r, 1)))) ' 基準：1列目（必要なら見出し検索に変更）
        If Len(k) = 0 Then GoTo cont
        If Not dict.Exists(k) Then
            wsOut.Range("A" & outRow).Resize(1, UBound(v, 2)).Value = Application.Index(v, r, 0)
            dict(k) = True
            outRow = outRow + 1
        End If
cont:
    Next

    wsOut.Columns.AutoFit
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "ユニーク抽出（単一キー）が完了。件数: " & outRow - 2
End Sub

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
  • 向いている場面: 元表を壊したくない、後工程にユニーク一覧を渡したい。
  • 拡張: 見出し名から列特定にすると、列順変更に強い。

複合キーのUNIQUE化（コード×日付など）

複数列の組み合わせで「同一」を判定し、ユニーク行だけ抽出します。

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

Sub Unique_Extract_MultiKey()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    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 wsOut As Worksheet: Set wsOut = EnsureSheet("ユニーク複合", True)

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

    Dim r As Long, key As String
    For r = 2 To UBound(v, 1)
        key = BuildCompositeKey(v(r, 1), v(r, 2)) ' 例：A=コード、B=日付
        If Len(key) = 0 Then GoTo cont
        If Not dict.Exists(key) Then
            wsOut.Range("A" & outRow).Resize(1, UBound(v, 2)).Value = Application.Index(v, r, 0)
            dict(key) = True
            outRow = outRow + 1
        End If
cont:
    Next

    wsOut.Columns.AutoFit
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "ユニーク抽出（複合キー）が完了。件数: " & outRow - 2
End Sub
VB
  • 向いている場面: 「コードが同じでも日付が違えば別扱い」など、現場のルールに合わせたいとき。
  • コツ: 区切り文字は「|」など安全な文字を使い、日付は yyyy-mm-dd に統一。

Excel 365/2021限定：UNIQUE関数をVBAから呼ぶ

動的配列対応の環境なら、ワンライナーでユニーク抽出が可能です。

Sub Unique_WithWorksheetFunction()
    Dim src As Range: Set src = Worksheets("Data").Range("A2:A1000") ' 抽出元
    Dim arr As Variant
    arr = WorksheetFunction.Unique(src) ' UNIQUEの戻りは配列になる（365/2021+）

    ' 出力
    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("UNIQUE関数", True)
    wsOut.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

    MsgBox "WorksheetFunction.Uniqueで抽出完了"
End Sub
VB
  • 向いている場面: 最新環境で、とにかく楽に・早く終わらせたい。
  • 注意点: 旧Excelでは使えない。環境要件の確認が必要。

例題で練習

'例1：元表を直接ユニーク化（最短）
Sub Example_BuiltIn()
    Unique_ByBuiltIn
End Sub

'例2：単一キーでユニーク一覧を抽出（安全）
Sub Example_ExtractSingle()
    Unique_Extract_SingleKey
End Sub

'例3：複合キーでユニーク一覧を抽出
Sub Example_ExtractMulti()
    Unique_Extract_MultiKey
End Sub

'例4：UNIQUE関数で一瞬抽出（365/2021）
Sub Example_UniqueFunc()
    Unique_WithWorksheetFunction
End Sub
VB

実務の落とし穴と対策

  • 表記揺れで別物扱いになる
    • 対策: キーは必ず正規化（Trim＋大文字化、必要なら半角化）。
  • 日付の形式違いで重複扱いがズレる
    • 対策: 比較前に Format(CDate(値),"yyyy-mm-dd") へ統一。
  • 列順が変わると壊れる
    • 対策: 見出し名から列特定（Find）を使う。ハードコードを避ける。
  • 「どれを残すか」ルールが曖昧
    • 対策: 先頭/最新/最大など運用ルールを決める。必要なら「プレビュー→適用」の2段階に分ける。
  • 大量データで遅い
    • 対策: Range→配列化、Dictionary、画面/イベント/計算の停止で高速化。
スポンサーリンク
タイトルとURLをコピーしました