マクロで統合

windows10エクセル2016で添付画像の様にSheet1のデータ(行指定)を統合してSheet2に集計したいのですがマクロで自動作成する事は可能でしょうか？

【Sheet1】
F列に「東京-001」など型番が表示されています。
H列に「黒」や「ｼﾙﾊﾞｰ/PINK」など色が表示されています。
I列に「37」や「38,39」などNoが表示されています。
L列に「10」など総数量が表示されています。

【Sheet2】
Sheet1の統合されたもの（A1に型番、B1に色、C1にNo、D1に総数量）が表示。


※統合するとき型番、色、Noが同じものは総数量を合算して、そうでないものはそのままを表示したいです。
※Sheet1の行データ個数は30行の時もあれば1000行と時もあります。

宜しくお願いします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2019/04/25 13:47

こんにちは！

両Sheetとも1行目は項目行になっているとします。
一例です。
標準モジュールにしてください。

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")
　　　lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　If lastRow > 1 Then
　　　　　Range(wS.Cells(2, "A"), wS.Cells(lastRow, "D")).ClearContents
　　　　End If
　　　　With Worksheets("Sheet1")
　　　　　lastRow = .Cells(Rows.Count, "F").End(xlUp).Row
　　　　　　myR = Range(.Cells(2, "F"), .Cells(lastRow, "L"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 3) & "_" & myR(i, 4) '//★//
　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　myDic.Add myStr, myR(i, 7)
　　　　　　　　　Else
　　　　　　　　　　myDic(myStr) = myDic(myStr) + myR(i, 7)
　　　　　　　　　End If
　　　　　　　Next i
　　　　　　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 With
End Sub

※　コードは長いですが、数万行のデータでもほとんど時間を要しないと思います。

※　コード内の「★」の行のアンダーバーは、Sheet1のデータ内に使っていない文字にしてください。m(_ _)m

この回答へのお礼

ありがとうございます。思っていた通りの事ができました！
関数で色々考えたことが一瞬で出来てしまうなんてびっくりしました。

お礼日時：2019/04/25 14:25