フォームに入力された日付のデータのみコピペする

質問

お世話になります。

前回に引き続きExcelのVBAについて質問させていただきます。
(前回も似たような質問なので申し訳ございません)

集計.xlsというブックがあります。
この中に[集計]、[東京支店]、[名古屋支店]、[大阪支店]というシートがあります。

前回の質問で[東京支店]、[名古屋支店]、[大阪支店]のシート内容を[集計]シートに順番にコピペすることは出来ました。回答をいただきました皆様ありがとうございました。

今度やりたいことは[東京支店]、[名古屋支店]、[大阪支店]のシート内容を[集計]シートに順番にコピペする時に1つ条件を付けて、[日付がXXXのデータのみコピぺする]といった具合にしたいのです。

各支店のシートの内容は以下の通りです。
日付]　[担当者]　[金額]
11/1 田中 100円
11/2 山田 500円

今回はフォーム(Form1)を作成して、条件に使う日付を"Text.box1"に入力させるようにしました。

[集計]シートに[東京支店]、[名古屋支店]、[大阪支店]の全データをコピー後に、このフォームを起動させてTextbox1に日付を入力させてから[抽出]というボタンを押したら以下VBAを起動させて、[集計]シートの
データを上から下まで全てREADして、Text.box1に入力された日付と異なるデータを削除する方法で実現しようと考えました。

しかし、削除するロジックがうまく動作せず、Textbox1に入力された日付と異なった[集計シート]の日付データでも削除するデータもあれば、削除しないデータもあります。
自分でやっていて効率が悪い方法だな、ともいます・・。

出来れば[集計]シートへのコピペ前にフォームを出して、Textbox1に条件の日付を入力させて[抽出]ボタンを押したら、Textbox1の日付のデータだけをコピペ出来れば最高です。

どなたかご教授いただけますでしょうか？

環境
Windows XP SP3
Excel2003

****VBA****

Sub test()

Dim 下 As Integer

'東京支店
Sheets("東京支店").Select
Range("A2").Select

'東京支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

'集計シートに貼り付け
Sheets("集計").Select
Range("A2").Select
ActiveSheet.Paste

'次は名古屋支店
Sheets("名古屋支店").Select
Range("A2").Select

'名古屋支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

'集計シートの最下行を取得
Sheets("集計").Select
下 = Cells(Rows.Count, 1).End(xlUp).Row　+1

'集計シートに貼り付け
Range("A2").Select
ActiveCell.Offset(下 ,0).Select
ActiveSheet.Paste

'最後に大阪支店
Sheets("大阪支店").Select
Range("A2").Select

'大阪支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

'集計シートの最下行を取得
Sheets("集計").Select
下 = Cells(Rows.Count, 1).End(xlUp).Row　+1

'集計シートに貼り付け
Range("A2").Select
ActiveCell.Offset(下 ,0).Select
ActiveSheet.Paste

'集計シートのデータを全READ
i=2
Do
'フォームのTextBox1に入力された日付以外は削除
If Cells(i, 1).Value <> TextBox1.Value Then
Rows(i & ":" & i).Select
Selection.Delete Shift:=xlUp
End If
i = i + 1
Loop Until Cells(i, 1) = ""

End Sub

回答No.1

keithin · ベストアンサー

こんばんは。

今のマクロで失敗しているのは、行を「上から下に向かって順に調べて、行削除している」からです。
下端行から順に上に向けて調べて削除していけば、失敗しません。定石なので、必ずマスターしておいてください。

で。
＞[日付がXXXのデータのみコピぺする]といった具合にしたいのです。

実際には、全データを１行ずつ舐めまわしながら操作していくのは、いかにも非効率です。（実際そういうマクロは、確かに簡単ですが一番遅いです）

とりあえず高速な手としては、各支店シートに「オートフィルタ」を取り付けて欲しい日付のデータだけ抽出し、そのままふつーにコピーして集約します。
今のマクロに「オートフィルタで絞り込む」だけ追加すれば、ほとんど変更なしに作成できます。

お礼

keithinさん、ご連絡が遅くなりまして申し訳ございません。

ご教授いただきましたオートフィルターの設定で実現できました！

複雑なロジックを組まないといけないのかな、と心配していたのですがこのようなシンプルな方法もあるのですね！

この度は本当にありがとうございました！！(^^)

補足

keithinさん、早速のご連絡ありがとうございます。
いつもありがとうございます。

なるほど！そkうゆーことだったのですね。。
とても勉強になりました。

ただ今からPCから離れてしまいますため後程ご教授いただきました方法で試させていただきます！

取り急ぎお礼申しあげます。

回答No.2

tsubuyuki

> '集計シートのデータを全READ
> i=2
> Do
> 'フォームのTextBox1に入力された日付以外は削除
> If Cells(i, 1).Value <> TextBox1.Value Then
> Rows(i & ":" & i).Select
> Selection.Delete Shift:=xlUp
> End If
> i = i + 1
> Loop Until Cells(i, 1) = ""

現状、２行目から初めて、最終行まで・・と上から下へ見に行ってますよね。
　１行目　　11/6　　い
　２行目　　11/5　　ろ
　３行目　　11/4　　は
　４行目　　11/6　　に
と入力されているセルを、例えば11/6日以外を削除、i=i+1して繰り返し・・と考えたとき、
１行目は11/6ですから、残してi=i+1して２行目を見に行きますね。
２行目は11/5ですから、削除対象です。行削除した結果、
　１行目　　11/6　　い
　２行目　　11/4　　は
　３行目　　11/6　　に
こうなりますね？　
でも、i=i+1で次は３行目（「に」の行）を見に行ってしまいます。
これでは現在の２行目（「は」の行）は残ってしまいますね。
これが行（列）削除・挿入を繰り返すときの落とし穴です。

この場合、下（右）から消していくのがセオリーとされています。
行を見るための変数iの初期値を「開始前の最終行」にしてやり、
１行処理したら「前の行」としてやるために、

　　'集計シートのデータを全READ
　　i=Cells(Rows.Count, 1).End(xlUp).Row
　　Do
　　　　'フォームのTextBox1に入力された日付以外は削除
　　　　If Cells(i, 1).Value <> TextBox1.Value Then
　　　　　　Rows(i).Delete Shift:=xlUp
　　　　End If
　　　　i = i - 1
　　Loop Until i = 1

こんな感じにします。

ここから先は好みの問題が大きく左右されますが、
“私なら”For～Nextを使います。

　　'集計シートのデータを全READ
　　'最終行から２行目まで、－１行しながら繰り返し
　　For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
　　　　'フォームのTextBox1に入力された日付以外は削除
　　　　If Cells(i, 1).Value <> TextBox1.Value Then
　　　　　　Rows(i).Delete Shift:=xlUp
　　　　End If
　　Next i

こんな感じですね。

お礼

tsubuyakinさん、ご連絡が遅くなりまして申し訳ございません。

最終行の調べ方、今後はしっかりと覚えていきたいと思います！

今回は他の方にご教授いただきましたオートフィルターで絞る方法で進めさせていただくことにしましたが、tsubuyakiさんからご教授いただきました方法でも実現できました！

この度は本当にありがとうございました！！(^^

補足

tsubuyakiさん、早速のご連絡ありがとうございます。
いつもありがとうございます。

そのような落とし穴だったのですね！
何回やってもおかしいなーと思っていたのです・・(^^)
とても勉強になりました。

ただ今からPCから離れてしまいますため後程ご教授いただきました方法で試させていただきます！

取り急ぎお礼申しあげます。