Excel VBA 逆引き集 | 区分ごとに重複除去

Excel VBA
スポンサーリンク

区分ごとに重複除去

「全体で重複を消すのではなく、“区分ごと”に重複を取りたい」——例えば「部門ごとにコードの重複を除去」「カテゴリごとに最新だけ残す」といった処理です。初心者でも安心して使えるように、コード例とテンプレをかみ砕いて説明します。

基本の考え方

  • 区分列: 部門・カテゴリ・グループなど、グループ分けの基準列。
  • キー列: 重複判定の対象（例：コード）。
  • 残すルール: 先頭を残す／最新日付を残す／件数を数えるなど。

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

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

テンプレ1：区分ごとに重複候補を一覧化（部門×コード）

「部門ごとにコードが重複している行」を候補として一覧に出します。
入力例：A列=部門、B列=コード。

Sub ListDuplicates_ByGroup()
    SpeedOn

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

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
    Dim dup As Object: Set dup = CreateObject("Scripting.Dictionary")

    Dim r As Long, groupKey As String, codeKey As String, key As String
    For r = 2 To lastRow
        groupKey = NormKey(ws.Cells(r, "A").Value) ' 部門
        codeKey = NormKey(ws.Cells(r, "B").Value) ' コード
        If Len(groupKey) = 0 Or Len(codeKey) = 0 Then GoTo cont
        key = groupKey & "|" & codeKey
        If seen.Exists(key) Then
            dup(key) = dup(key) & "," & r
        Else
            seen(key) = True
            dup(key) = CStr(r)
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("区分別重複候補", True)
    out.Range("A1:D1").Value = Array("部門", "コード", "出現回数", "行番号一覧")

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In dup.Keys
        Dim arrKey() As String: arrKey = Split(k, "|")
        Dim arrPos() As String: arrPos = Split(dup(k), ",")
        If UBound(arrPos) >= 1 Then
            out.Cells(i, 1).Value = arrKey(0)
            out.Cells(i, 2).Value = arrKey(1)
            out.Cells(i, 3).Value = UBound(arrPos) + 1
            out.Cells(i, 4).Value = dup(k)
            i = i + 1
        End If
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "区分ごとの重複候補一覧を作成しました"
End Sub
VB
  • ポイント: 部門×コードの複合キーで判定。候補一覧に行番号を残すので確認が容易。

テンプレ2：区分ごとに重複削除（先頭を残す）

「部門ごとにコードが重複していたら、最初の行だけ残して後は削除」します。

Sub RemoveDuplicates_ByGroup()
    SpeedOn

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

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

    Dim r As Long, groupKey As String, codeKey As String, key As String
    For r = 2 To lastRow
        groupKey = NormKey(ws.Cells(r, "A").Value)
        codeKey = NormKey(ws.Cells(r, "B").Value)
        If Len(groupKey) = 0 Or Len(codeKey) = 0 Then GoTo cont
        key = groupKey & "|" & codeKey
        If seen.Exists(key) Then
            delRows.Add r
        Else
            seen(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
  • ポイント: 削除は必ず「下から」。上から削除すると行番号がズレます。

テンプレ3：区分ごとに最新日付だけ残す（コード×部門）

「部門ごとにコードが複数ある場合、最新日付の行だけ残す」ルール。
入力例：A=部門、B=コード、C=日付。

Sub KeepLatest_ByGroup()
    SpeedOn

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

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

    Dim latest As Object: Set latest = CreateObject("Scripting.Dictionary")
    Dim r As Long, key As String, d As Date
    For r = 2 To UBound(v, 1)
        key = NormKey(v(r, cGroup)) & "|" & NormKey(v(r, cCode))
        If IsDate(v(r, cDate)) Then
            d = CDate(v(r, cDate))
            If Not latest.Exists(key) Or d > latest(key) Then
                latest(key) = d
            End If
        End If
    Next

    Dim delRows As Collection: Set delRows = New Collection
    For r = 2 To UBound(v, 1)
        key = NormKey(v(r, cGroup)) & "|" & NormKey(v(r, cCode))
        If IsDate(v(r, cDate)) Then
            d = CDate(v(r, cDate))
            If d < latest(key) Then delRows.Add rg.Row + r - 1
        End If
    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
  • ポイント: 最新日付を保持→古い行を削除。区分×コード単位で判定。

例題で練習

'例1：部門ごとにコードの重複候補一覧を作成
Sub Example_ListGroupDup()
    ListDuplicates_ByGroup
End Sub

'例2：部門ごとにコードの重複を削除（先頭を残す）
Sub Example_RemoveGroupDup()
    RemoveDuplicates_ByGroup
End Sub

'例3：部門ごとにコードの最新日付だけ残す
Sub Example_KeepLatest()
    KeepLatest_ByGroup
End Sub
VB

初心者向けポイント

  • 複合キー: 「区分|コード」で一意に判定。区切り文字は「|」が安全。
  • 削除は下から: 行番号ズレ防止の鉄則。
  • まずは候補一覧: いきなり削除せず、候補を出して確認→承認→削除が安心。
  • 日付統一: CDate＋Format("yyyy-mm-dd")で表記揺れを吸収
スポンサーリンク
タイトルとURLをコピーしました