ExcelのVBAで2次元配列の重複を削除する方法｜Dictionaryでキー列を指定し、シートを触らずに一意の行だけを残す

シートの行を直接消す前に、重複を除いた結果を確認したいことがあります。元のシートはそのままにして、重複を除いた一覧を別の場所に作りたい場合もあるでしょう。このようなときは、Range.Value で表を2次元配列に読み込み、VBAの中で重複を除いてから書き出す方法が向いています。

この記事では、Dictionary（連想配列）を使い、1列または複数列をキーにして重複を判定します。最初に出てきた1行だけを残した新しい配列を作り、書き出す前に件数を確認するところまで説明します。

前提

• Windows版Excelを前提にしています。Dictionaryには Scripting.Dictionary を使うため、Mac版Excelでは動きません。
• Range.Value で読み込んだ配列は、行・列とも1から始まる2次元配列です。コードはこの形を前提にしています。
• 元のシートには何も書き込みません。結果は新しいシートに書き出します。

処理の流れ

1. 表全体を Range.Value で2次元配列に読み込む
2. 行ごとにキー（重複の判定に使う文字列）を作る
3. キーがまだDictionaryにない場合だけ、その行番号を「残す行」として記録する
4. 残す行の数が決まってから、その行数分の新しい配列を作って値をコピーする
5. 元の件数・残す件数・除く件数を表示して確認する
6. 確認できたら、新しいシートに書き出す

4で行数が決まってから配列を作るのは、VBAの ReDim Preserve では2次元配列の最後の次元（列）しか広げられないためです。行を1つずつ追加しながら配列を広げることはできないので、先に残す行の番号だけを集めておきます。

キーの作り方を先に決める

重複かどうかは、キーが同じかどうかだけで判定されます。コードを書く前に、次の点を決めておきます。

コード1：重複を除いた配列を返す関数

Option Explicit

' 2次元配列から、キーが重複する行を除いた新しい配列を返す
' data       : Range.Valueで読み込んだ配列（1始まり）
' keyCols    : キーにする列番号　例) Array(1) / Array(1, 3)
' hasHeader  : True なら1行目を見出しとして必ず残す
' ignoreCase : True なら大文字・小文字を区別しない
Function RemoveDuplicateRows(data As Variant, keyCols As Variant, _
                             ByVal hasHeader As Boolean, _
                             Optional ByVal ignoreCase As Boolean = False) As Variant
    Dim dict As Object
    Dim keepRows() As Long
    Dim result() As Variant
    Dim r As Long, c As Long, i As Long
    Dim firstRow As Long, keepCount As Long
    Dim key As String

    Set dict = CreateObject("Scripting.Dictionary")
    If ignoreCase Then dict.CompareMode = vbTextCompare

    ReDim keepRows(1 To UBound(data, 1))
    firstRow = 1

    If hasHeader Then
        keepCount = 1
        keepRows(1) = 1
        firstRow = 2
    End If

    ' 1回目：残す行番号だけを集める（最初に出てきた行を残す）
    For r = firstRow To UBound(data, 1)
        key = MakeKey(data, r, keyCols)
        If Not dict.Exists(key) Then
            dict.Add key, r
            keepCount = keepCount + 1
            keepRows(keepCount) = r
        End If
    Next r

    ' 2回目：残す行だけを新しい配列にコピーする
    ReDim result(1 To keepCount, 1 To UBound(data, 2))
    For i = 1 To keepCount
        For c = 1 To UBound(data, 2)
            result(i, c) = data(keepRows(i), c)
        Next c
    Next i

    RemoveDuplicateRows = result
End Function

' 指定した列の値をつないで、1行分のキーを作る
Private Function MakeKey(data As Variant, ByVal r As Long, keyCols As Variant) As String
    Dim sep As String
    Dim k As Long
    Dim v As Variant
    Dim s As String

    sep = ChrW(31) ' データに含まれにくい制御文字を区切りに使う

    For k = LBound(keyCols) To UBound(keyCols)
        v = data(r, keyCols(k))
        If IsError(v) Then
            s = "#ERROR"
        Else
            s = Trim$(CStr(v))
        End If
        If k > LBound(keyCols) Then MakeKey = MakeKey & sep
        MakeKey = MakeKey & s
    Next k
End Function

コードを読むときのポイントは次のとおりです。

• 残るのは、上から順に見て最初に出てきた行です。
• keyCols に指定する列番号は、シート上の列番号ではなく、読み込んだ範囲の左端から数えた位置です。表がB列から始まっている場合は、B列が1になります。
• 前後の空白をそのままキーに含めたい場合は、Trim$(CStr(v)) を CStr(v) に変えます。
• Dictionaryには、キーと一緒に残した行番号も入れています。あとで紹介する「除いた行の記録」で使います。

コード2：件数を確認してから新しいシートに書き出す

Sub DedupeToNewSheet()
    Dim src As Range
    Dim data As Variant
    Dim result As Variant
    Dim outWs As Worksheet
    Dim beforeCount As Long, afterCount As Long

    Set src = ThisWorkbook.Worksheets("元データ").Range("A1").CurrentRegion

    If src.Rows.Count < 2 Then
        MsgBox "見出し以外のデータがないため処理しません。"
        Exit Sub
    End If

    data = src.Value

    ' 1列目と3列目の組み合わせをキーにする（見出しあり）
    result = RemoveDuplicateRows(data, Array(1, 3), True)

    beforeCount = UBound(data, 1) - 1   ' 見出しを除いた件数
    afterCount = UBound(result, 1) - 1

    If MsgBox("元の件数：" & beforeCount & vbCrLf & _
              "残る件数：" & afterCount & vbCrLf & _
              "除く件数：" & (beforeCount - afterCount) & vbCrLf & vbCrLf & _
              "新しいシートに書き出しますか？", vbYesNo + vbQuestion) = vbNo Then
        Exit Sub
    End If

    Set outWs = ThisWorkbook.Worksheets.Add( _
        After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    outWs.Range("A1").Resize(UBound(result, 1), UBound(result, 2)).Value = result
End Sub

シート名「元データ」、開始セル、キーにする列は、実際の表に合わせて変えてください。CurrentRegion は空白の行や列があるとそこで止まるため、実行前に Debug.Print src.Address で読み込む範囲を確認しておくと安心です。

数式が入っているセルは、Range.Value で計算結果の値として読み込まれます。書き出した結果は数式ではなく値になります。

書き出すときに値が変わらないようにする

読み込んだ値をそのまま書き出すと、書き出し先のセルの書式によって値が変わることがあります。よくあるのは、文字列として入力されていた「001」のようなコードです。書き出し先の書式が標準のままだと、数値の1として入力されてしまいます。

先頭の0を残したい列は、書き出す前にその列の表示形式を文字列にしておきます。

    ' 1列目（コード列）を文字列として書き出す
    outWs.Columns(1).NumberFormat = "@"
    outWs.Range("A1").Resize(UBound(result, 1), UBound(result, 2)).Value = result

桁数の多い番号や、日付のように見える文字列も、同じように別の値に変わることがあります。こうした列があれば、同じように表示形式を指定してください。

どの行を残すかを変えたいとき

この関数は、上から順に見て最初に出てきた行を残します。「日付が最も新しい行を残したい」場合は、日付の新しい順に並べ替えてから読み込めば、コードを変えずに済みます。元のシートの並び順を変えたくない場合は、シートを複製し、複製したほうを並べ替えて読み込みます。

除いた行を記録する

どの行がどの行の重複として除かれたかを確認したい場合は、関数の中の If 文を次のように書き換えます。

        If Not dict.Exists(key) Then
            dict.Add key, r
            keepCount = keepCount + 1
            keepRows(keepCount) = r
        Else
            Debug.Print "除外：" & r & "行目（同じキーで残した行：" & dict(key) & "行目）"
        End If

ここでの行番号は、読み込んだ範囲の中の行番号です。範囲がA1から始まっていれば、シートの行番号と一致します。イミディエイトウィンドウに表示できる行数には限りがあり、件数が多いと古い行から消えていきます。除いた行が多い場合は、記録用の配列を作ってシートに書き出してください。

結果を確かめる

書き出したら、次の点を確認します。

• 件数の関係：元の件数−残る件数＝除く件数になっているか（メッセージに表示された数字で確認する）
• 結果にキーの重複が残っていないか：書き出したシートを同じキー列で関数にもう一度通し、件数が変わらないかを確かめる
• 除いた行の中身：除かれた行のキーをいくつか選び、元データの該当する行と見比べて、本当に重複として扱ってよいかを確認する
• 値が変わっていないか：先頭の0、桁数の多い番号、日付が、元データと同じように表示されているか
• 元のシート：元データのシートの行数や内容が変わっていないか

2つ目の確認は、次のようなマクロで行えます。書き出したシートを選択した状態で実行し、イミディエイトウィンドウに表示される2つの数字が同じなら、キーの重複は残っていません。

Sub CheckNoDuplicates()
    Dim data As Variant
    data = ActiveSheet.Range("A1").CurrentRegion.Value
    Debug.Print UBound(data, 1), UBound(RemoveDuplicateRows(data, Array(1, 3), True), 1)
End Sub

つまずきやすい点

シートの行を直接消す方法と違い、この方法なら、結果を確かめてから使うかどうかを決められます。まず新しいシートに書き出し、件数と中身を確認してから、本来の作業に使ってください。