もう少し、スマートにもできますが、一応こんな感じはどうですか?
いくつものファイルから自動的に集計するのかな?と解釈しました。
何かのお役に立ててください。
(段落下げは面倒でやってません。一部長いところもあり見づらくてゴメンナサイ)
やっているのは品名を探し、日付を探して、そのクロスするところに数量をプラスしています。
同じ物を何度も足さないように、フラグもつけました。
上手くいかない場合は日付を文字列にしていただくと上手くいくかも・・・。
Sub 合計()
'【前提】
'複数ファイルが有っても列の構成は変わらない
'1行目に品名・合計・日付・登録となっている
'ファイルの存在場所は特定のフォルダ(ここではC:\とします)
'集計ファイルでボタンを押すと集計します(マクロもここに書きます)
'集計する品名は集計ファイルにすべてかかれています(かかれて無くても方法はありますが)
Dim tmp As Range, wb As Workbook, y As Integer, x As Integer, fn
ChDir ("c:\")
fn = Dir("c:\*.xls") 'ファイル名でさらにしぼれるならしぼってください(c:\*集計.xlsなど)
Do Until fn = ""
Set wb = Workbooks.Open(fn)
y = 2
Do
If wb.Sheets(1).Cells(y, 4) = "" Then
Set tmp = ThisWorkbook.Sheets(1).Columns(1).Find(wb.Sheets(1).Cells(y, 1), , xlWhole)
If Not tmp Is Nothing Then
y = tmp.Row
Set tmp = ThisWorkbook.Sheets(1).Rows(1).Find(wb.Sheets(1).Cells(y, 3), , xlWhole)
If Not tmp Is Nothing Then
x = tmp.Column
ThisWorkbook.Sheets(1).Cells(y, x) = ThisWorkbook.Sheets(1).Cells(y, x) + wb.Sheets(1).Cells(y, 2)
wb.Sheets(1).Cells(y, 4) = Now()
End If
End If
End If
y = y + 1
Loop Until wb.Sheets(1).Cells(y, 1) = ""
wb.Close True
fn = Dir()
Loop
End Sub
お礼
大変ありがとうございます。ただ早速試してみたところどうしても<インデックスが有効範囲ではありません>と途中で止まってしまいます。デバッグでみたら下のところが黄色くなっています。何卒宜しくお願いいたします。 Set tmp = ThisWorkbook.Sheets(1).Columns(1).Find(wb.Sheets(1).Cells(y, 1), , xlWhole) If Not tmp Is Nothing Then