マクロで納品書を集計

業者から届くエクセルファイルの納品書があります。
1つのフォルダに格納するとして、月100枚くらいになります。
ひとつの課で何番の商品を何本、金額がいくら分発注しているかを集計したいです。

課名D16
商品名B20:B39
枚数H20:H39
金額I20:I39

のセルをそれぞれ別Bookに集計するマクロを教えてください。
20～39のセルには発注の内容によって可変します。

集計のBookは上記の4項目をA1～D1に横に並べればOKです。

新しい仕事を引き継ぎ、アナログな集計を変えたいのですが
上司に相談できず困っています。
お知恵をお貸しいただけたらと思います。
何卒よろしくお願いします。

No.1 回答者： fujillin 回答日時： 2009/05/18 16:39

課名のコードとか、商品名のコードなどはないのでしょうか？

というのは、納品書を作成するのは複数の業者でしょうから、必ずしも同じ課や商品に対して、正確に同じ内容が記載されているとは限りません。
（例えば、「ボールペン」と「水性ボールペン」など）
これをそのまま比較すると、違う商品となったり、実際には違うものが同じとカウントされたり…

また、ご質問文では、納品書の書式が不明ですし（1ブック、1シートで1商品のみ記載？そのシート名は同じなのか違うのか？）、集計の書式もよくわからないので（集計対象はどうするのか、全部を適当に集計するのかなど）コードでの回答は無理です。
（もともと、丸投げは規約違反みたいですが…）

いずれにしろ、1/3～1/2くらいまではマクロの自動記録でもできますのでそのあたりがとっかかりになるのではないでしょうか？
◆指定したもの（部課あるいは商品）を集計するのなら、
　各ブックをオートフィルタなど（他の方法でもよい）でフィルタリングして、
　該当するものを集計

◆全部を集計して整理するのなら
1）納品書を開いて、項目をチェック
　未集計の項目の場合、上記の集計を行う。
　　（開いている自分自身のブックも対象になることに注意）
　集計済みの項目の場合は、2）へ
2）集計の記載位置を、次の位置へセット。
　納品書の次の項目に対して1）の処理を行う。
3）同様にして順次全ブックに対して1）、2）を行う。

（↑）こちらの処理は少々時間がかかる可能性があります。
全部のブックを同時に開いておいて処理した方が速いと思うけど、一度に100個のブックが開けるか実験したことがないので、可能かどうか不明です。

この回答への補足

早速のご回答ありがとうございます。
なんだかとても焦ってしまい、質問が雑になってしまいました。
申し訳ありません。

課名＝課コード（数値）ですので類似はありません。


1　ファイル内の納品書のブックを開いて→
2　行20～39の数値がある行だけコピー→
3　集計用ブックに貼り付け→
4　納品書のブックを閉じる
5　次のブックを開く・・・・

というような作業を行いたいと思ってました。
タイトル、金額の集計は集計用ブックでピポットテーブルで行います。

ファイル内のブックに同じマクロを一気に適応するやり方が
判りませんでしたのでネットなどで調べてやってみましたが
動作がうまくいきませんでした。

Okwaveも初心者のため、申し訳ありません。
質問が不適切でしたら削除いたしますので
ご指摘の程よろしくお願いします。

補足日時：2009/05/18 16:54

No.2 回答者： merlionXX 回答日時： 2009/05/18 17:10

一例です。

その100件くらいの集計対象のBOOKが入っているフォルダーに以下のマクロを書いたエクセルBOOK（転記先）を保存してください。（パス取得のため必ず「保存」してください。）
そのフォルダー内には集計対象のBOOKと、このマクロを書いたBOOKしかないものとします。
集計対象BOOKのシート名の記載がありませんでしたので、開いたときに出てくるシート（ActiveSheet）を対象にしています。
転記先BOOKのシート名の記載がありませんでしたのでSheet1とします。

Sub test01()
Dim MyFile As String, MyPath As String '変数宣言
Dim x As Long, y As Long
Dim wb As Workbook, tb As Workbook
Dim ka As String
Dim sh1, sh2
Set tb = ThisWorkbook
MyPath = tb.Path & "\" '自分のパスを取得
MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル
Application.ScreenUpdating = False '画面更新停止
Do While MyFile <> "" 'エクセルファイルがなくなるまで
If MyFile <> tb.Name Then '自分以外のファイルを対象
Set wb = Workbooks.Open(MyPath & "\" & MyFile) '選択したファイルを開く
With ActiveSheet
ka = .Range("D16").Value '課
x = .Range("B" & Rows.Count).End(xlUp).Row '最終行
sh1 = .Range("B20:B" & x).Value '商品名
sh2 = .Range("H20:I" & x).Value '数量＆金額
End With
With tb.Sheets("Sheet1")
y = .Range("B" & Rows.Count).End(xlUp).Row '最終行
y = IIf(.Range("B" & y) = "", y, y + 1)
.Range("A" & y).Resize(x - 19, 1).Value = ka '転記
.Range("B" & y).Resize(x - 19, 1).Value = sh1
.Range("C" & y).Resize(x - 19, 2).Value = sh2
End With
wb.Close (False) '選択したファイルを閉じる
End If
MyFile = Dir() '次のファイルを検索
Loop '繰り返し
Application.ScreenUpdating = True '画面更新停止解除
End Sub

No.3 ベストアンサー 回答者： merlionXX 回答日時： 2009/05/18 18:28

No2 merlionXXです。

何度か試したところ、納品書BOOKのActivesheet B20以下にデータが入ってないとエラーになりますね。
そんなケースはないのならいいですが、万一の用心にコードを修正しました。他の部分も若干いじってます。

Sub test02()
Dim MyFile As String, MyPath As String '変数宣言
Dim x As Long, y As Long
Dim wb As Workbook, tb As Workbook
Dim ka As String
Dim sh1, sh2
Set tb = ThisWorkbook
MyPath = tb.Path & "\" '自分のパスを取得
MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル
Application.ScreenUpdating = False '画面更新停止
Application.Calculation = xlCalculationManual '自動計算停止
Do While MyFile <> "" 'エクセルファイルがなくなるまで
If MyFile <> tb.Name Then '自分以外のファイルを対象
Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く
With ActiveSheet
ka = .Range("D16").Value '課名取得
x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
sh1 = .Range("B20:B" & x).Value '商品名取得
sh2 = .Range("H20:I" & x).Value '数量＆金額取得
End With
With tb.Sheets("Sheet1")
y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
y = IIf(.Range("B" & y) = "", y, y + 1)
If x >= 20 Then '納品書B20以下にデータがあれば
Set myRng = .Range("A" & y).Resize(x - 19, 1)
myRng.Value = ka '課名転記
myRng.Offset(, 1).Value = sh1 '商品名転記
myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記
End If
End With
wb.Close (False) '選択したファイルを閉じる
End If
MyFile = Dir() '次のファイルを検索
Loop '繰り返し
Application.Calculation = xlCalculationAutomatic '自動計算停止解除
Application.ScreenUpdating = True '画面更新停止解除
Set tb = Nothing
Set wb = Nothing
Set myRng = Nothing
End Sub

この回答へのお礼

お返事が遅くなって申し訳ありません。
早速試してみましたが、うまくいきました！
本当に助かります。
そしてコメントまで付けて下さり
勉強になります。
内容をじっくり勉強したいと思ってます。
また機会がありましたらよろしくお願いします。

お礼日時：2009/05/19 09:22