同じものを集計するマクロ

質問

月に１度、発行した注文書のデータ（約９０００件）のデータから
品番毎に発注した個数を集計しなければいけません。
約９０００件もあるので、手作業だと非常に時間がかかってしまうので、
自動（マクロ）で行い、時間短縮をしたいと思っています。
どのようにすれば良いでしょうか。
サンプルの表と出来上がりなどは下記のとおりです。

サンプルデータ
----------------------
|仕入先|品番|個数|納期|
----------------------
|Ａ１　　|2222|１０|０５|
----------------------
|Ａ１　　|2222|１２|０８|
----------------------
|Ａ１　　|2222|０８|１０|
----------------------
|Ａ１　　|3333|１０|０３|
----------------------
|Ａ２　　|4444|１５|０４|
----------------------
|Ａ２　　|5555|１０|１０|
----------------------

上表から、
１．不要な列（縦）は削除（上表では納期）
２．同じ仕入先、同じ品番のものを合計（１行にまとめる）する。
３．仕入先毎にシートを分ける。

完成した表
シート１
-----------------
|仕入先|品番|個数|
-----------------
|Ａ１　　|2222|３０|
-----------------
|Ａ１　　|3333|１０|
-----------------

シート２
-----------------
|仕入先|品番|個数|
-----------------
|Ａ２　　|4444|１５|
-----------------
|Ａ２　　|5555|１０|
-----------------

回答No.1

hogehage · ベストアンサー

こんな感じでしょうか。

　入力も出力も列は、
■Ａ列：仕入先、Ｂ列：品番、Ｃ列：個数　としています。
■また、２行目からデータがあるものとしています。
■出力するシートは追加しています。
　(見出しは書いていません)

Dim SIIRE_SAKI() As String '仕入先
Dim HINBAN() As String '品番
Dim KOSUU() As Double '個数
Dim IDX As Double 'インデックス

REDIM_CNT = 200 '仕入先+品番の組み合わせの最大数
ReDim SIIRE_SAKI(REDIM_CNT)
ReDim HINBAN(REDIM_CNT)
ReDim KOSUU(REDIM_CNT)

'「集計」----------------------------------------------------------
Worksheets("Sheet1").Select '読み込みむ明細シート
END_ROW = Range("A65536").End(xlUp).Row 'Ａ列の最下行
For ii = 2 To END_ROW '２行目から最下行をループ
　For kk = 1 To IDX '配列をループ
　　If Cells(ii, "A").Value = SIIRE_SAKI(kk) _
　　　And Cells(ii, "B").Value = HINBAN(kk) Then '配列に同一の仕入先+品番が見つかった
　　　KOSUU(kk) = KOSUU(kk) + Cells(ii, "C").Value '個数を加算
　　　FOUND# = 1 '見つかった
　　　Exit For
　　End If
　Next kk
　If FOUND# = 0 Then '配列になかった
　　'配列に追加
　　IDX = IDX + 1
　　SIIRE_SAKI(IDX) = Cells(ii, "A").Value
　　HINBAN(IDX) = Cells(ii, "B").Value
　　KOSUU(IDX) = Cells(ii, "C").Value
　End If
　FOUND# = 0 '配列になしにリセット
Next ii

'「書き出し」------------------------------------------------------
For ii = 1 To IDX
　'仕入先が前件と同じ
　If SIIRE_SAKI(ii) = SIIRE_SAKI(ii - 1) Then
　　W_ROW = W_ROW + 1
　　Cells(W_ROW, "A").Value = SIIRE_SAKI(ii)
　　Cells(W_ROW, "B").Value = HINBAN(ii)
　　Cells(W_ROW, "C").Value = KOSUU(ii)

　　'仕入先が変わった
　Else
　　Worksheets.Add 'シート追加
　　ActiveSheet.Name = SIIRE_SAKI(ii) 'シート名を仕入先にする
　　Worksheets(SIIRE_SAKI(ii)).Move After:=Worksheets(Worksheets.Count) '一番最後にシート移動
　　'書き込み
　　Worksheets(SIIRE_SAKI(ii)).Select
　　W_ROW = 2
　　Cells(W_ROW, "A").Value = SIIRE_SAKI(ii)
　　Cells(W_ROW, "B").Value = HINBAN(ii)
　　Cells(W_ROW, "C").Value = KOSUU(ii)
　End If
Next ii

お礼

お礼が遅くなりすいません。
ほぼイメージどおりのものができました。
（質問内容からすれば完璧です）
ここから少し手を加えて、完成度を上げていきます。
ありがとうございました。

回答No.2

papayuka

完成イメージとは少し違うけど、ピボットテーブルでページの表示をすれば簡単に分けられますよ。

ページフィールドに「仕入先」
行フィールドに「品番」
データアイテムに「個数」

でピボットを作り、仕入先で右クリックして「ページの表示」