エクセルVBA「重複したデータ行を集計した上で、削除する」

エクセルVBAの便利マクロ「キー列が重複したデータ行を、集計対象列（複数）を集計した上で、最上段の行を残して削除するマクロ」をシェアします。

参考になれば幸いです。

機能紹介
マクロコード紹介
まとめ

機能紹介

以下のようなデータに対し、マクロを動かすと

以下のように、重複した行を削除するとともに、集計対象列に集計します。

マクロコード紹介

コードは以下の通りです

Option Explicit

'*** Private変数宣言
Private oBook      As Object
Private oSht      As Object
Private sShtName    As String
Private nSRow      As Integer
Private nERow      As Long
Private nCRow      As Long
Private nCCol      As Integer
Private nCol()     As Integer
Private cSum()     As Currency
Private nVal      As Integer
Private nErr         As Integer
Private sMsg         As String
Private nL1          As Long
Private vTmp         As Variant
Private rTmp         As Range
Private nCnt1        As Long
Private sTmp         As String


'### 行集約_複合集計プロシージャ

Sub 行集約()

On Error GoTo ErrChk
 
  '*** 初期設定
  nErr = 0
  Set oBook = ActiveWorkbook
  Set oSht = ActiveSheet
  sShtName = ActiveSheet.Name
 
  '*** Undoデータを残す
  sMsg = "Undoデータを別シートに保存しますか"
  If MsgBox(sMsg, vbYesNo + vbQuestion) = vbYes Then
   
    For nL1 = 1 To oBook.Sheets.Count
      If Sheets(nL1).Name = "Undo" Then
        Application.DisplayAlerts = False
        Sheets("Undo").Delete
        Application.DisplayAlerts = True
        Exit For
      End If
    Next nL1
   
    oSht.Copy Before:=Sheets(1)
    ActiveSheet.Name = "Undo"
   
    oSht.Select
   
  End If
 
  '*** 座標設定
  sMsg = "集計対象の列数を指定"
  vTmp = InputBox(prompt:=sMsg, Default:=1)
  If vTmp = "" Then
    nErr = 1
    GoTo ErrChk
  Else
    If CInt(vTmp) <= 0 Then
      nErr = 2
      GoTo ErrChk
    Else
      nVal = vTmp
    End If
  End If
   
  ReDim cSum(nVal) As Currency
  ReDim nCol(nVal) As Integer
 
  sMsg = "判定開始行を選択"
  Set rTmp = Application.InputBox(prompt:=sMsg, Type:=8)
  nSRow = rTmp.Row
 
  sMsg = "判定対象列を選択"
  Set rTmp = Application.InputBox(prompt:=sMsg, Type:=8)
  nCCol = rTmp.Column
 
  '*** 最終行判定
  nERow = oSht.Cells(Rows.Count, nCCol).End(xlUp).Row
  If nSRow >= nERow Then
    nErr = 3
    GoTo ErrChk
  End If
 
  For nL1 = 1 To nVal
    sMsg = "集計対象列 (" & nL1 & ") を選択"
    Set rTmp = Application.InputBox(prompt:=sMsg, Type:=8)
    nCol(nL1) = rTmp.Column
  Next nL1
 
  '*** 判定対象列をキーにソート
  oSht.Rows(nSRow & ":" & nERow).Sort Key1:=oSht.Cells(nSRow, nCCol), Header:=xlNo
 
  '*** 集計ループ(最初の行を残して重複行を削除)
  nCnt1 = 0
  nCRow = nSRow
  Do Until nCRow >= nERow + 1
   
    '判定対象値の比較
    sTmp = oSht.Cells(nCRow, nCCol).Value
    If sTmp = oSht.Cells(nCRow + 1, nCCol).Value Then
     
      '重複行数カウント
      nCnt1 = nCnt1 + 1
     
      '集計対象値の加算
      For nL1 = 1 To nVal
        cSum(nL1) = cSum(nL1) + oSht.Cells(nCRow, nCol(nL1)).Value
      Next nL1
     
    Else
     
      '重複行数判定
      If nCnt1 > 0 Then
       
        '加算値をセット
        For nL1 = 1 To nVal
          cSum(nL1) = cSum(nL1) + oSht.Cells(nCRow, nCol(nL1)).Value
          oSht.Cells(nCRow - nCnt1, nCol(nL1)).Value = CLng(cSum(nL1))
        Next nL1
       
        '重複行削除
        oSht.Rows(nCRow - nCnt1 + 1 & ":" & nCRow).Delete Shift:=xlUp
        nCRow = nCRow - nCnt1
        nERow = nERow - nCnt1
        nCnt1 = 0
       
        '集計値をリセット
        For nL1 = 1 To nVal
          cSum(nL1) = 0
        Next nL1
       
      End If
     
    End If
   
    nCRow = nCRow + 1
   
  Loop
 
 
  '*** 終了処理
  sMsg = "正常終了"
  MsgBox sMsg, vbOKOnly + vbInformation
  Set oBook = Nothing
  Set oSht = Nothing
  Set rTmp = Nothing
  Exit Sub
 
ErrChk:
  '*** ユーザーエラーコード
  Select Case nErr
  Case 0         'エラーなし
    sMsg = sMsg
  Case 1         'Cancelボタン
    Set oBook = Nothing
    Set oSht = Nothing
    Set rTmp = Nothing
    End
  Case 2
    sMsg = "入力値違反"
  Case 3
    sMsg = "処理対象なし"
  Case Else
    sMsg = "予期せぬエラー nErr = " & nErr
  End Select
 
  '*** ＶＢＡエラーコード
  Select Case Err
  Case 0         'エラーなし
    sMsg = sMsg
  Case 424        'Cancelボタン
    Set oBook = Nothing
    Set oSht = Nothing
    Set rTmp = Nothing
    End
  Case Else
    sMsg = "予期せぬエラー Err = " & Err
  End Select
 
  MsgBox sMsg, vbOKOnly + vbCritical
  Set oBook = Nothing
  Set oSht = Nothing
  Set rTmp = Nothing
  End
 
End Sub