VBAで一定期間の名簿を検索、抽出できますか？

質問

お世話になっております。皆さんよろしくお願いします。
Aという名前のエクセルファイルのsheet1に次のような名簿が入力してるとします。

　　A　　　　　B　　　　C　　　　　D
1　申請日　　名前　　　住所　　電話番号
2　　4/1　　　甲　　　東京　　　00－0000
3　　4/2　　　乙　　　大阪　　　11－1111
4　　4/3　　　丙　　　京都　　　22－2222
・　　4/3　　　虎　　　北海道　　33－3333　　　
・　　・　　　　・　　　・　　　　　・
こういう名簿が3000件くらいあります。申請日は一件しかない日もあれば、数百件ある日もあります。また、申請日は一概に4/1から順になっていないところもあります。
この名簿を他のBというエクセルファイルに指定した期間ごとに抽出したいと考えています。
例えば、Bファイルのsheet1に、
　　A　　　　　B　　　　C　　　　 ～　　G
1　4/3　　　　4/4　　　4/5　　　　～　　4/9

と一週間分を入力し、コマンドボタンを押したら、Bファイルのsheet2
に、

　　A　　　　　B　　　　C　　　　　D
1　申請日　　名前　　　住所　　電話番号
2　　4/3　　　大田　　　京都　　　22－2222　　
3　　4/3　　　佐藤　　　北海道　　33－3333　　　
・　　・　　　　・　　　　・　　　　・
・　　・　　　　・　　　　・　　　　・
11　 4/9 　　 山田　　　愛知　　44－4444　　　

できたら嬉しいのですが、できるのでしょうか？どなたかお知恵をお貸しください。
よろしくお願いします。

回答No.1

-yellowtail- · ベストアンサー

簡単にできると思います！

単純に考えれば、Aファイルを1行ずつループで回して行き、日付をFindでBファイルのSheet1から探します。見つかればSheet2にコピー。
その場合Sheet2の貼り付け行はEndで取るか、貼りつけるごとに変数をインクリメントでOKだと思います。

また日付が日付形式ならまずSortして期間の分だけコピーした方が早いと思います。
ソートしたあと、日付の抜けがないならFindで初日と最終日を探し、抜けがあるならループで回して初日より大きくなる日を探すというのでどうでしょう？

指定する日が連続でないなら、最初の方法が良いかなと思います。
他に良い方法があるかも知れませんが、3000件ならループで回しても時間はそんなにかからないと思います☆

えーと・・・

Dim y as integer
dim i as integer
dim tmp as range

y=1:i=1
do
　　set tmp=workbooks("B").sheets(1).rows(2).find(workbooks("A").sheets(1).cells(y,1),lookat:=xlwhole)
　　if not tmp is nothing then
　　　　Workbooks("B").sheets(2).cells(i,1)=workbooks("A").sheets(1).cells(y,1)
　　　　'～略～
　　　　i=i+1
　　end if
　　y=y+1
loop until y=workbooks("A").sheets(1).range("A65536").end(xlup).row

上記コードはちょっと適当だけど、こんな感じでどうでしょう？

お礼

回答ありがとうございます。返事遅れて申し訳ありませんでした。これを参考にしてみたら見事にできました！！ほんと助かりました。今後もどうぞよろしくお願いします。

回答No.3

fumufumu_2006

一部仕様を変えてしまう方法ですが・・・

Bファイルのsheet1の、
　　A　　　　　B　　　　C　　　　 ～　　G
1　4/3　　　　4/4　　　4/5　　　　～　　4/9
を
　　A
1　申請日
2　4/3
3　4/4
...
8　4/9
ということにしてもらえるなら、
[データ][フィルタ][フィルタオプションの設定]
と
[データ][並べ替え]
を
VBAで行う事で、比較的簡単にできます。

Bファイル(B.xls)のsheet1にボタンがあるとします。
Aファイル(A.xls)は開いているとします。

Private Sub CommandButton1_Click()
Dim srcBook As Workbook
Dim dstBook As Workbook
Set srcBook = Workbooks("A.xls") '元データのブック
Set dstBook = Workbooks("B.xls") '集計先ブック(自分自身?）
Dim SourceRange As Range
Dim CriteriaRange As Range
Dim CopyToRange As Range
Dim ws As Worksheet '長い名前を省略するための一時的な変数
'[データ][フィルタ][フィルタオプションの設定]
'expression.AdvancedFilter(Action, CriteriaRange, CopyToRange, Unique)
Set ws = srcBook.Sheets("Sheet1")
Set SourceRange = ws.Range("A1:D" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
Set ws = dstBook.Sheets("Sheet1")
Set CriteriaRange = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
Set CopyToRange = dstBook.Sheets("Sheet2").Range("A1")
dstBook.Sheets("Sheet2").Cells.Clear '集計シートクリア
SourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CriteriaRange, CopyToRange:=CopyToRange, Unique:=False
'[データ][並べ替え]
'expression.Sort(Key1, Header)
Set ws = dstBook.Sheets("Sheet2")
Set SourceRange = ws.Range("A1:D" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
SourceRange.Sort Key1:=ws.Range("A2"), Header:=xlYes
End Sub

お礼

返事遅れて申し訳ありませんでした。今回は＃１さんのを参考にさせてもらいました。fumufumu_2006さんの中にあるコードで”Criteria”とか”srcBook”とか解らない単語もあるので、もう少し勉強してみます。今後もまたよろしくお願いいたします。

回答No.2

imogasi

また抜き出し法の質問。
２つ３つぐらいヒントで
（１）個別にSheet2へ、ばら撒き法
各行データを初めから終わりまで読むが、条件（本質問では日付け範囲）に該当するかIF文で聞く。
該当すればSheet２に書き出す。（＃１のご回答はこれか？）
書き出す場所を決める方法は
Sheet2の最終行を、書き出すその都度捉える方法（end(Xlup).Row)
変数（例ｋ）で管理し条件該当分１行をSheet2に書き出すごとにk=k+1する
などある
（２）一括抜き出し法
日付け（プラス必要あればそれも加えて）でソートする。
Sheet1を触れないなら、別シートにコピーして、そちらでソート。
そしてソートしたシートを全行読んで、日付け範囲に該当すればその行塊りを１度にSheet2に書き出す。
（３）ピボットテーブル
　　　フィルタオプションの設定
などをVBAで操作して、該当分を作る。
（４）先ほど別質問で出したが、MSクエリなど（データー外部データの取り込み・・）で、アクセスでおなじみの、SQLの利用に持ち込む（日付け範囲で抜き出す）

お礼

返事遅れて申し訳ありません。業務の上で抜き出し法をよく使用するため、imogasiさんにはいつもお世話になっております。今後もどうぞよろしくお願いいたします。