VBAで重複データを合算したい

Question

下記データの羅列がありますがこれをVBAで合算したいですのですが、
どのような構文にすれば良いかご教授頂けないでしょうか。
（今VBAでマクロを組んでいますが、それにこの処理を埋め込みたいです。）

1行目はタイトル行で2列目以降はデータ（間に空白行は存在しません）
　　　A列　　      B列　　C列　　D列
1　 　日付      　  名前1   名前2　数量
2　 　2018/7/22  AAAA  BBBB　500
3　 　2018/7/22  AAAA  BBBB　700
4　 　2018/7/29  AAAA  BBBB　500
5　 　2018/7/29  CCCC  DDDD　500
6　 　2018/7/29  CCCC  DDDD　500

↓A列,B列,C列が全て同じデータの場合、D列の数量を合算して一つにまとめる。

　　　A列　　      B列　　C列　　D列
1　 　日付      　  名前1   名前2　数量
2　 　2018/7/22  AAAA  BBBB　1200
3　 　2018/7/29  AAAA  BBBB　500
4　 　2018/7/29  CCCC  DDDD　1000

下記を参考にしようと思いましたがVBA初心者の為、複数条件の設定をどうすれば良いか
理解出来なかったためご教授お願いします。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14116323219

tom04 · Accepted Answer

こんばんは！

＞データ量は13000ぐらいあります。

速度重視でやってみました。
元データはSheet1にあり、Sheet2に表示するとします。

標準モジュールです。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myKey, myItem, myR, myAry
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:D").ClearContents
　　　　With Worksheets("Sheet1")
　　　　　wS.Range("A1:C1").Value = .Range("A1:C1").Value
　　　　　wS.Range("D1") = "合計"
　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "D"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 3)
　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　myDic.Add myStr, myR(i, 4)
　　　　　　　　　Else
　　　　　　　　　　myDic(myStr) = myDic(myStr) + myR(i, 4)
　　　　　　　　　End If
　　　　　　　Next i
　　　　End With
　　　myKey = myDic.keys
　　　myItem = myDic.items
　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "D"))
　　　　　For i = 0 To UBound(myKey)
　　　　　　myAry = Split(myKey(i), "_")
　　　　　　　myR(i + 1, 1) = myAry(0)
　　　　　　　myR(i + 1, 2) = myAry(1)
　　　　　　　myR(i + 1, 3) = myAry(2)
　　　　　　　myR(i + 1, 4) = myItem(i)
　　　　　Next i
　　　　Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "D")) = myR
　　　　　Set myDic = Nothing
　　　　　wS.Activate
　　　　　MsgBox "完了"
End Sub

※　コードは長いですが、
そんなに時間は要しないと思います。m(_ _)m

fujillin · Answer

No2です

＞データ量多いのでやはりこれぐらいの時間はかかってしまうでしょうか？
すでに他の回答があるので、いまさらお答えする必要もないとは思いますが、そのようなことはありません。
処理の内容にもよりますけれど機械にとってはさほどの量ではないと思います。

No1にも記しましたが、
＞どのような構文にすれば良いかご教授頂けないでしょうか。
とのことでしたので、できるだけ簡単な記述で済む方法にしています。
そのため、通常はあまり使わないであろう方法での処理になっています。
そのかわりに、VBAの記述は、単純なステートメントを順に記述すればよい形式になっていると言えます。
（まぁ、ほとんどの計算を関数式にやらせているので、VBAは手順だけの記述で済む）

通常は、他の方の回答のような発想で処理すると思いますが、「構文がわからない」という質問者様には考え方を説明しても伝わらない可能性があると思いましたので・・・

tatsu99 · Answer

No4です。標準モジュールに登録してください。
------------------------------------------------------------
Option Explicit
Public Sub 重複データ合算()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key As Variant
    Dim dicT As Object
    Dim t1, t2
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set dicT = CreateObject("Scripting.Dictionary")
    t1 = Time
    sh2.Cells.Clear
    maxrow1 = sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row
    sh2.Range("A1:D1").Value = sh1.Range("A1:D1").Value
    maxrow2 = 2
    For row1 = 2 To maxrow1
        key = sh1.Cells(row1, "A").Value & "|" & sh1.Cells(row1, "B").Value & "|" & sh1.Cells(row1, "C").Value
        If dicT.Exists(key) = False Then
            dicT(key) = maxrow2
            sh2.Range("A" & maxrow2 & ":D" & maxrow2).Value = sh1.Range("A" & row1 & ":D" & row1).Value
            maxrow2 = maxrow2 + 1
        Else
            row2 = dicT(key)
            sh2.Cells(row2, "D").Value = sh2.Cells(row2, "D").Value + sh1.Cells(row1, "D").Value
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    t2 = Time
    MsgBox ("処理時間=" & Format(t2 - t1, "n分s秒"))
End Sub

tatsu99 · Answer

元データのシートがSheet1、まとめる先のシートがSheet2でも良いですか？

fujillin · Answer

No1です

実際になさりたいことは何なのかよくわかりませんが、元データを削除するような雰囲気になっているようなので、もしも、それでよいのでしたなら・・・

※ 削除はせずに、対象行を選択した状態にしています。
※ A列は必ず2行目以降までデータがあるものと仮定しています。
　（データ無しのチェックはしていません）

Set R = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Offset(, 4)
R.FormulaLocal = "=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,"""",SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))"
R.Value = R.Value
R.SpecialCells(xlCellTypeBlanks).EntireRow.Select

fujillin · Answer

こんにちは

＞どのような構文にすれば良いかご教授頂けないでしょうか。
普通に処理すると、重複をチェックしたり検索集計したりとそれなりに面倒なので、通常はあまりやらないかも知れませんが、VBA的には比較的簡単な例を

1）E列を作業列に利用します。
　（E列が使われている場合は、Columns(5).Insert などで挿入）
2）使用セルの最下行を求める。
　Cells(Rows.Count, 1).End(xlUp)など
3）対象範囲の各行E列に以下の式を設定
　関数式の設定は、Range().FormulaLocal = 式 などで可能
　設定する関数式は
=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,"",SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))

以上のセッティングができれば、E列に結果が表示されますので、E列を調べて値のある行だけピックアップすれば、お望みの結果となるでしょう。
例えば、結果を別のシートに抽出するなら、
　For Each c In E列の範囲
　　If c.value <> "" Then この行を書き写す処理
　Next c
のような感じで可能でしょう。

最後に、E列を削除（あるいは値をクリア）しておけば、データのシートは元の状態になります。

VBAで重複データを合算したい

こんばんは！

No2です

No4です。

元データのシートがSheet1、まとめる先のシートがSheet2でも良いですか？

No1です

こんにちは

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング