フォームに入力された日付のデータのみコピペする
お世話になります。
前回に引き続き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
お礼
ご回答ありがとうございます。