Excel VBA 逆引き集 | 重複行を１行にまとめる

Excel VBA
スポンサーリンク

重複行を1行にまとめる

「同じキーが複数行に分かれているので、1行にまとめたい」——集計やレポートでよく出る要望です。初心者でも安心して使えるように、基本の考え方からコード例、応用までかみ砕いて説明します。

基本の考え方

  • キー列: 「同じ」と判定する基準（例：コード）。
  • まとめ方:
    • 数値列は合計・平均などにまとめる。
    • 文字列列は結合して1セルにまとめる。
  • 出力: 元表は壊さず、別シートに「まとめ済み一覧」を作る。

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

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：数値列を合計して1行にまとめる

入力例：「Data」シートに A=コード、B=商品名、C=数量、D=金額。
出力：「まとめ」シートにコードごとに数量合計・金額合計を1行にまとめる。

Sub MergeDuplicateRows_Sum()
    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 dictQty As Object: Set dictQty = CreateObject("Scripting.Dictionary")
    Dim dictAmt As Object: Set dictAmt = CreateObject("Scripting.Dictionary")
    Dim dictName As Object: Set dictName = CreateObject("Scripting.Dictionary")

    Dim r As Long, k As String
    For r = 2 To UBound(v, 1)
        k = NormKey(v(r, 1)) ' コード
        If Len(k) = 0 Then GoTo cont
        dictQty(k) = CDbl(Val(dictQty(k))) + CDbl(Val(v(r, 3)))
        dictAmt(k) = CDbl(Val(dictAmt(k))) + CDbl(Val(v(r, 4)))
        If Not dictName.Exists(k) Then dictName(k) = v(r, 2)
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("まとめ", True)
    out.Range("A1:D1").Value = Array("コード", "商品名", "数量合計", "金額合計")

    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In dictQty.Keys
        out.Cells(i, 1).Value = key
        out.Cells(i, 2).Value = dictName(key)
        out.Cells(i, 3).Value = dictQty(key)
        out.Cells(i, 4).Value = dictAmt(key)
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "重複行をまとめました。件数: " & i - 2
End Sub
VB
  • ポイント: 同じコードの数量・金額を合計して1行に。

テンプレ2：文字列列を結合して1行にまとめる

入力例：A=コード、B=担当者。
出力：コードごとに担当者を「,」区切りでまとめる。

Sub MergeDuplicateRows_Concat()
    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 dictConcat As Object: Set dictConcat = CreateObject("Scripting.Dictionary")

    Dim r As Long, k As String
    For r = 2 To UBound(v, 1)
        k = NormKey(v(r, 1)) ' コード
        If Len(k) = 0 Then GoTo cont
        If dictConcat.Exists(k) Then
            dictConcat(k) = dictConcat(k) & "," & v(r, 2)
        Else
            dictConcat(k) = v(r, 2)
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("まとめ文字列", True)
    out.Range("A1:B1").Value = Array("コード", "担当者一覧")

    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In dictConcat.Keys
        out.Cells(i, 1).Value = key
        out.Cells(i, 2).Value = dictConcat(key)
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "文字列列を結合してまとめました。件数: " & i - 2
End Sub
VB
  • ポイント: 同じコードの担当者を「A,B,C」と1セルにまとめる。

テンプレ3：最新日付の行だけ残す（古い行はまとめない）

入力例：A=コード、B=日付、C=数量。
出力：コードごとに最新日付の行だけ残す。

Sub MergeDuplicateRows_KeepLatest()
    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 latestDate As Object: Set latestDate = CreateObject("Scripting.Dictionary")
    Dim latestRow As Object: Set latestRow = CreateObject("Scripting.Dictionary")

    Dim r As Long, k As String, d As Date
    For r = 2 To UBound(v, 1)
        k = NormKey(v(r, 1))
        If Len(k) = 0 Or Not IsDate(v(r, 2)) Then GoTo cont
        d = CDate(v(r, 2))
        If Not latestDate.Exists(k) Or d > latestDate(k) Then
            latestDate(k) = d
            latestRow(k) = r
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("まとめ最新", True)
    out.Range("A1:C1").Value = Array("コード", "最新日付", "数量")

    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In latestRow.Keys
        out.Cells(i, 1).Value = v(latestRow(key), 1)
        out.Cells(i, 2).Value = v(latestRow(key), 2)
        out.Cells(i, 3).Value = v(latestRow(key), 3)
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "最新日付の行だけ残しました。件数: " & i - 2
End Sub
VB
  • ポイント: 最新日付だけ残すので「まとめ」というより“抽出”に近い。

例題で練習

'例1：コードごとに数量・金額を合計して1行にまとめる
Sub Example_Sum()
    MergeDuplicateRows_Sum
End Sub

'例2：コードごとに担当者を結合して1行にまとめる
Sub Example_Concat()
    MergeDuplicateRows_Concat
End Sub

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

初心者向けポイント

  • まずは別シート出力: 元表を壊さないので安心。
  • キー正規化: 空白や大小文字の違いで別物扱いにならないように。
  • まとめ方を決める: 数値は合計／文字列は結合／日付は最新など、ルールを明確に。
  • 削除は下から: 実際に元表を削除する場合は必ず「下から」処理。
スポンサーリンク
タイトルとURLをコピーしました