【excel vb】重複データをチェックしてその行を削除・表を集計して整頓するマクロ

会社で在庫管理表を作成しているのですが、大変困っております。
マクロ初心者で技術不足なのでどうかご教授願います。

　　 1　　　2　　 3　 4
　部品名　材料名　 寸法　 数量
　チャンネル 　　SS400　 180*75*6.5　 10
　アングル 　　SS400　 50*50*6　 5
　チャンネル 　 SS400　 180*75*6.5　 2
　チャンネル　　SS400　 180*100*6　 4
　チャンネル 　　SUS304　 180*75*6.5　 12
　アングル 　　SS400　 50*50*6　 10
　FB 　　SS400　 60*4　 1
　FB 　　SS400　 60*4　 7
これを1列目「部品名」をキーとして「材料名、寸法」を確認し、同じ（つまり同じ物）であればその行を削除して、数量を加算して1行にまとめるマクロを作りたいのです。ポイントは(1)1列目「部品名」の重複確認のみで行削除ではなく、２、3列目「材料名、寸法」も確認する必要があることと、(2)削除してからその「部品名」がある行に削除した「数量」分加算しなくてはいけないことだと考えているのですが・・・。
　　1　　　2　　 3　 4
　部品名　材料名　寸法　 数量
　チャンネル　SS400　180*75*6.5　 12
　チャンネル　SS400　180*100*6　　4
　チャンネル　SUS304　180*75*6.5　12
　アングル　　SS400　50*50*6　　　15
　FB　　　　　SS400　60*4　　　8
　　7/7 　　C　 DC200　 7
説明が分かりづらいかもしれませんが、どうか宜しくお願い致します。

No.1 回答者： tom04 回答日時： 2017/05/23 20:09

こんばんは！

別シート表示でも良いですか？
元データはSheet1にあり、Sheet2に表示するとします。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, lastRow1 As Long, lastRow2 As Long
Dim c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("E:E").Insert
.Range("E1") = "ダミー"
Range(.Cells(2, "E"), .Cells(lastRow1, "E")).Formula = "=A2&B2&C2"
.Range("E:E").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
lastRow2 = wS.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow2
Set c = .Range("E:E").Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
wS.Cells(i, "B").Resize(, 3).Value = .Cells(c.Row, "A").Resize(, 3).Value
Next i
With Range(wS.Cells(2, "E"), wS.Cells(lastRow2, "E"))
.Formula = "=SUMIF(Sheet1!E:E,A2,Sheet1!D:D)"
.Value = .Value
End With
wS.Range("A:A").Delete
.Range("E:E").Delete
.Range("A1").Resize(, 4).Copy wS.Range("A1")
wS.Columns.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　Sheet1の出現順に表示されます。m(_ _)m

この回答へのお礼

早速のご返答ありがとうございました。

別シートでも問題ありませんので助かりました

お礼日時：2017/05/24 06:09

No.2 回答者： ママチャリ 回答日時： 2017/05/23 21:08

「手作業でやったら、こんな感じ」をマクロ化してみました。

新しいシートを作成して、集計しています。

Sub sample()
Dim wsn As String
wsn = "'" & ActiveSheet.Name & "'"
ActiveSheet.Copy before:=Sheets(1)
ActiveSheet.Range("A:D").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
Range("D2:D" & Cells(Rows.Count, "A").End(xlUp).Row).Formula = _
"=SUMIFS(" & wsn & "!D:D," & wsn & "!A:A,A2," & wsn & "!B:B,B2," & wsn & "!C:C,C2)"
Columns("D:D").Copy
Columns("D:D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
End Sub

この回答へのお礼

本当に助かりました、勉強になります。

ありがとうございました

お礼日時：2017/05/24 06:19

No.3 回答者： tom04 回答日時： 2017/05/23 22:22

No.1です。

元データに手を付けても良いのであれば・・・
別解です。

Sub Sample2()
Dim i As Long, lastRow As Long, c As Range
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("E:E").Insert
Range(Cells(2, "E"), Cells(lastRow, "E")).Formula = "=A2&B2&C2"
For i = lastRow To 3 Step -1
Set c = Range("E:E").Find(what:=Cells(i, "E"), LookIn:=xlValues, lookat:=xlWhole)
If c.Row <> i Then
With Cells(c.Row, "D")
.Value = .Value + Cells(i, "D")
Rows(i).Delete
End With
End If
Next i
Range("E:E").Delete
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じでも同じ結果になると思います。m(_ _)m

この回答へのお礼

別のアプローチまで考えて頂きありがとうございました。

色々勉強させて貰いました

お礼日時：2017/05/24 06:19