条件を満たす場合のみ計算、満たさない場合はそのまま

質問

Excel2010です。

Sheet2にデータを貼り付けSheet1で集計を行うファイルを作成しています。

Sheet1の集計表は
項目｜6/1｜6/2｜6/3｜6/4｜6/5｜・・・
林檎｜001｜000｜000｜000｜003｜・・・
蜜柑｜000｜001｜000｜001｜000｜・・・
巨峰｜000｜001｜000｜000｜000｜・・・

Sheet2のデータは
2011/06/01｜林檎｜
2011/06/02｜蜜柑｜
2011/06/02｜巨峰｜
2011/06/04｜蜜柑｜
2011/06/05｜林檎｜
2011/06/05｜林檎｜
2011/06/05｜林檎｜

上記のような状態になっています。

集計自体は関数を入れれば簡単にできるのですが、
今回やりたいのは、

Sheet2にある日付だけ再計算し、
Sheet2に無い日付に関しては値をそのままにしておく。

という関数またはVBAです。

理由はいくつかあるのですが、
■全データを貼り付けると重いのでできるだけ1日（当日）分にしたい
■当日分にしてしまうと集計し忘れた日の処理が大変

の2点が主な理由です。

これができれば集計が必要な日のデータだけ吐き出してSheet2に貼り付ければ
必要な集計が行える形になります。

何か良い方法はありますでしょうか。よろしくお願いいたします。

回答No.3

tom04

No.1です！
たびたびごめんなさい。

通常、Sheet2にデータを貼り付けるたびにSheet1のA列（品目？）が増えるのが普通だと思いますので、それにも対応できるようにコードに少し手を加えてみました。

Sub test()
Dim i, j, k As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For k = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(ws1.Columns(1), ws2.Cells(k, 2)) = 0 Then
ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws2.Cells(k, 2)
End If
Next k
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For k = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(1, j) = ws2.Cells(k, 1) And ws1.Cells(i, 1) = ws2.Cells(k, 2) Then
ws1.Cells(i, j) = ws1.Cells(i, j) + 1
End If
Next k
Next j
Next i
End Sub

こんなんではどうでしょうか？m(__)m

回答No.2

mu2011

>Sheet2にある日付だけ再計算し、Sheet2に無い日付に関しては値をそのままにしておく。
　⇒マクロ（ＶＢＡ）になります。
　　少々、時間が掛っても正確性からすれば、全データ貼り付け方式の方が良いのではないでしょうか。
　　又、COUNTIFS関数のように複数条件による計数が可能であり、数式もシンプルです。
　　どうしてもマクロ（ＶＢＡ）という事ならば、同様の集計マクロ例がありますのでこちらを参考にしてみて下さい。

参考URL：

http://www.niji.or.jp/home/toru/notes/17.html

回答No.1

tom04

こんにちは！

＞Sheet2にある日付だけ再計算し、
＞Sheet2に無い日付に関しては値をそのままにしておく。

とありますのでVBAでの方法になると思います。

一例ですがコードを載せておきます。
尚、Sheet1のA列（品目？）はあらかじめ入力してあるものとし、日付はすべてシリアル値とします。
画面左下にある操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面が出ますので
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）
一旦マクロを実行すると元に戻せませんので、別Sheetでマクロを試してみてください。

Sub test() 'この行から
Dim i, j, k As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For k = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
'↑Sheet2のデータが1行目からであれば「2」を「1」に変更！
If ws2.Cells(k, 1) = ws1.Cells(1, j) And ws2.Cells(k, 2) = ws1.Cells(i, 1) Then
ws1.Cells(i, j) = ws1.Cells(i, j) + 1
End If
Next k
Next j
Next i
End Sub 'この行まで

的外れならごめんなさいね。m(__)m