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

下記データの羅列がありますがこれを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/questio …

No.6 回答者： fujillin 回答日時： 2018/10/23 08:53

No2です

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

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

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

この回答へのお礼

ありがとうございます。
ご教授頂きました構文を基に勉強致します。

お礼日時：2018/10/23 09:39

No.5 回答者： tatsu99 回答日時： 2018/10/22 20:24

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

この回答へのお礼

ありがとうございます。
処理速度早くきれいに処理する事が出来ました。
大変助かりました。

お礼日時：2018/10/22 21:29

No.4 回答者： tatsu99 回答日時： 2018/10/22 18:52

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

この回答へのお礼

ありがとうございます。
元データのシートがSheet1、まとめる先のシートがSheet2で問題ございません。

お礼日時：2018/10/22 19:29

No.3 ベストアンサー 回答者： tom04 回答日時： 2018/10/22 18:26

こんばんは！

＞データ量は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

この回答へのお礼

ありがとうございます。
すごく処理早くてびっくりしました。
大変助かりました。

お礼日時：2018/10/22 19:25

No.2 回答者： fujillin 回答日時： 2018/10/22 17:06

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

この回答へのお礼

ありがとうございます。
やりたいことの動作的にはご提供頂きました構文であっています。
処理が早くなりましたが、3分ほど時間が掛かってしまうようですが、
データ量（13000ぐらい）多いのでやはりこれぐらいの時間はかかってしまうでしょうか？
（ちょっと強引？ですが、処理時間が掛かるようであればピボットテーブル作成を
VBAに組み込んでみようと思っています。）

Dim t1, t2, t3
t1 = Time
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
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
Application.Calculation = xlCalculationAutomatic
t2 = Time
Selection.Delete Shift:=xlToLeft
t3 = Time
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox ("FINISH TIME1=" & Format(t2 - t1, "n分s秒") _
& vbCrLf & _
"FINISH TIME2=" & Format(t3 - t2, "n分s秒"))

上記で、FINISH TIME1が2分30秒ぐらい、FINISH TIME2が45秒ぐらいです。

お礼日時：2018/10/22 18:18

No.1 回答者： fujillin 回答日時： 2018/10/22 14:34

こんにちは

＞どのような構文にすれば良いかご教授頂けないでしょうか。
普通に処理すると、重複をチェックしたり検索集計したりとそれなりに面倒なので、通常はあまりやらないかも知れませんが、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列を削除（あるいは値をクリア）しておけば、データのシートは元の状態になります。

この回答へのお礼

ありがとうございます。
「例えば～」がどうすれば良いかわからなかったので、計算結果をコピー→値貼り付け→0の結果のところ
（IF文の空白だとうまくいかなかったので0にしています）を削除みたいにしてみましたが、値を貼り付け
のところで5分ぐらいかかってしまいました・・・。
データ量は13000ぐらいあります。

Application.Calculation = xlCalculationManual
Range("E1").Formula = "合計数量"
Range("E2").Formula = _
"=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,0,SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))"
Range(Cells(2, 5), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 5)).FillDown
ActiveSheet.Calculate
Range(Cells(2, 5), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 5)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Dim LastRow1 As Long
LastRow1 = Cells(Rows.Count, "E").End(xlUp).Row
With ActiveSheet
.Range("E:E").AutoFilter Field:=1, Criteria1:="0"
If .Cells(Rows.Count, "E").End(xlUp).Row > 1 Then
Range(.Cells(2, "E"), .Cells(LastRow1, "E")).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
.AutoFilterMode = False
End With

お礼日時：2018/10/22 16:30