Excelマクロで元データを簡潔な表に整形したい

Excelマクロで実現させたいのですが、どのようにすれば
良いのか悩み中です。

下記のような【ベース】の表を【整形後】に一覧表に
したいと思っています。

記入条件
品番が同じであっても出荷日が違う場合はそれぞれ記入する
品番と出荷日が同じであれば出庫数を足して記入する

これを実現させるにはどのような手順？でマクロを組めば
良いでしょうか？どなたか助けて下さい。


【ベース】
品番　　品名　　　出庫数　　出荷日
A-01　　りんご　　　10　　　2/21
A-01　　りんご　　　10　　　2/27
A-02　　もも　　　　10　　　2/21
A-02　　もも　　　　15　　　2/21

【整形後】
品番　　品名　　　出庫数　　出荷日
A-01　　りんご　　　10　　　2/21
A-01　　りんご　　　10　　　2/27
A-02　　もも　　　　25　　　2/21

No.1 ベストアンサー 回答者： tom04 回答日時： 2014/03/19 14:20

こんにちは！

一例です。

Sub Sample1()
Dim i As Long, lastRow As Long, c As Range
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
If lastRow > 1 Then
Range("A:A").Insert
With Range(Cells(2, "A"), Cells(lastRow, "A"))
.Formula = "=B2&""_""&E2"
.Value = .Value
End With
End If
For i = lastRow To 2 Step -1
If WorksheetFunction.CountIf(Range("A:A"), Cells(i, "A")) > 1 Then
Set c = Range("A:A").Find(what:=Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c.Offset(, 3) = c.Offset(, 3) + Cells(i, "D")
Cells(i, "A").Resize(, 5).Delete shift:=xlUp
End If
End If
Next i
Range("A:A").Delete
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？

※　一旦マクロを実行すると元に戻せませんので
別Sheetでマクロを試してみてください。m（_ _）m

この回答へのお礼

完ぺきでした！
ありがとうございました！

お礼日時：2014/03/19 14:46