エクセルVBAをつかってフォルダ内のファイルの特定シートのデータを１つのシートにまとめる

はじめまして。
過去ログ検索しましたが、載っていないようなので投稿させていただきます。

ブックAがあるフォルダ内にある「○年*.xls」のさらに「○月（○月以外のシートもあり）」のシート内の特定のセル（範囲は固定されてます）の文字列を、全てブックAの１つのシートにまとめたいのですが、VBAにてこれは可能ですか？
フォルダ内のファイルが複数だったり、またそのファイル内の該当シートが１つだったり複数だったりで、かなり行き詰ってます。

どなたかご存知の方いらっしゃいましたらご教授願います。
エクセル２０００を使用しております。

No.1 回答者： n-jun 回答日時： 2008/09/01 10:26

Sub test()

Dim wb As Workbook
Dim ws As Worksheet
Dim r As Range, rr As Range
Dim fname As String
Dim pname As String

Application.ScreenUpdating = False

'貼り付けるシート名は適宜変更
Set r = ThisWorkbook.Worksheets("Sheet1").Range("A1")

pname = ThisWorkbook.Path & "\"

fname = Dir(pname & "*.xls")

Do Until fname = ""

If InStr(fname, "年") Then
Workbooks.Open Filename:=pname & fname
Set wb = ActiveWorkbook

For Each ws In wb.Worksheets
If InStr(ws.Name, "月") Then

Set rr = ws.Range("A1:B5") '取り出したいデータ範囲
rr.Copy r
Set r = r.End(xlDown).Offset(1)
End If
Next

wb.Close False
End If

fname = Dir()
Loop

Application.ScreenUpdating = True
End Sub
ご参考まで。
（ブックを開かずにやる方法は苦手ですので、開いています。）

この回答へのお礼

早速ご回答いただきありがとうございます。
ブックは開いても全然問題ありません。

>Set r = r.End(xlDown).Offset(1)
の(1)は消してもよかったんですよね？消さないと動かなかったもので・・・
あと、ちゃんと取り出したいデータを貼り付けてくれるのですが、全てA1に貼り付けされてしまい、結局最後に開かれたデータがA1に貼り付けられて終わってしまうのですが、このような場合はどうしたらよいでしょうか？
私も自分で調べてみます。
ご丁寧にありがとうございます。本当に助かります。

お礼日時：2008/09/01 11:01

No.2 回答者： hana-hana3 回答日時： 2008/09/01 10:34

＞過去ログ検索しましたが、載っていないようなので投稿させていただきます。

基本になる部分は過去ログでもエクセルのサンプルが載ったＨＰでも沢山あると思いますよ。
柔軟に利用できる知識があれば参考にして自力で基本部分は出来るはずです。

＞フォルダ内のファイルが複数だったり、またそのファイル内の該当シートが１つだったり複数だったりで、かなり行き詰ってます。

どんな状態になっているのか解りませんが、文字列関数を利用してチェックすれば一定の選択は可能です。
条件から外れる場合はそれなりのチェックや抽出を行う仕組みにすれば良いでしょう。

No.3 回答者： n-jun 回答日時： 2008/09/01 11:21

ANo.1です。

>>Set r = r.End(xlDown).Offset(1)
>の(1)は消してもよかったんですよね？消さないと動かなかったもので・・・
消していいものではありませんけど。
消すと貼り付けたデータの最終行に次のデータが貼り付いてしまい、
１行足りなくなります。

>あと、ちゃんと取り出したいデータを貼り付けてくれるのですが、全てA1に貼り付けされてしまい、
>結局最後に開かれたデータがA1に貼り付けられて終わってしまうのですが、このような場合はどうしたらよいでしょうか？
上記【Set r = r.End(xlDown).Offset(1)】がＡ１以降の行に順次貼り付けていくためのコードです。
検証した範囲では問題なく動いていましたが。。。

この回答への補足

度々すいません。
デバッグすると２周目の「Set r = r.End(xlDown).Offset(1)」で止まってしまうという意味です。
「アプリケーション定義またはオブジェクト定義のエラーです」と表示されてしまいます。

補足日時：2008/09/01 11:51

この回答へのお礼

ありがとうございます。
今はフォルダ内に２つの該当ファイル、両方とも該当シートが２つある状況でテストしています。
とりあえず、コードはそのまま(1)を消さずに動いていますが、どうしても２週目で止まってしまいます。
１週目はちゃんと貼り付けてくれるんですけどね・・・。
でもこんなに丁寧に解説してくれて本当に助かります。
ありがとうございます！

お礼日時：2008/09/01 11:50

No.4 回答者： n-jun 回答日時： 2008/09/01 12:09

ANo.3です。

>デバッグすると２周目の「Set r = r.End(xlDown).Offset(1)」で止まってしまうという意味です。
>「アプリケーション定義またはオブジェクト定義のエラーです」と表示されてしまいます。
提示された情報以外に何かあるのでしょうか・・・・？
コードをどのように変更されたのか憶測がつきません。
可能であれば提示願います。

この回答への補足

ほぼいじっていないですが・・・

Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim r As Range, rr As Range
Dim fname As String
Dim pname As String

Application.ScreenUpdating = False


'貼り付けるシート名は適宜変更
Set r = ThisWorkbook.Worksheets("Sheet2").Range("A1")

pname = ThisWorkbook.Path & "\"

fname = Dir(pname & "*年*.xls")

Do Until fname = ""

If InStr(fname, "年") Then
Workbooks.Open Filename:=pname & fname
Set wb = ActiveWorkbook

For Each ws In wb.Worksheets
If InStr(ws.Name, "*年*月*") Then

Set rr = ws.Range("B2") '取り出したいデータ範囲
rr.Copy r
Set r = r.End(xlDown).Offset(1)
End If
Next

wb.Close False
End If

fname = Dir()
Loop

Application.ScreenUpdating = True

End Sub

こんな感じです。
もしかしたらパスやファイル名の指定に問題があるのかも・・・
ファイル名、シート名には法則があるので（ファイル名には「年」、シート名には「年.月」が必ず入ります）その辺は問題ないと思うのですが・・・。
何度もお手数おかけしてしまって申し訳ないです。

補足日時：2008/09/01 12:21

No.5 ベストアンサー 回答者： n-jun 回答日時： 2008/09/01 13:08

ANo.4です。

セル範囲とは１セル（１行）だったのですね。
ならばエラーになりますね。
>Set r = r.End(xlDown).Offset(1)
１行ずつ移動させるのでしたら、
Set r = r.Offset(1)
でよろしいかと。

ついでですが、
>If InStr(ws.Name, "*年*月*") Then
で問題は出ていませんか？
こちらではシートを見つけられずデータが貼り付きません。
If InStr(ws.Name, "年") * InStr(ws.Name, "月") Then
このように致しました。

この回答へのお礼

返事が送れてすいません。
わざわざ本当にありがとうございます。
助かります。
セル範囲は複数です。
基本(A2:D30)の値のみを貼り付けられるように今現在色々と調べているところです。
ご丁寧にお答えいただきありがとうございました。

お礼日時：2008/09/02 09:05

No.6 回答者： n-jun 回答日時： 2008/09/02 09:39

ANO.5です。

>セル範囲は複数です。
>基本(A2:D30)の値のみを貼り付けられるように
提示されたコードとの食い違いがありますが。。。
複数であればANo.5での変更は必要ないです。
或いは、
Set r = r.Offset(r.Rows.Count)
ですか。

コードは貼り付ける位置がＡ１からですが、これが別のセルを基準となるのなら、
適宜修正願います。

この回答へのお礼

なかなかうごかなかったので、とりあえず一行で動かしてました。
ですが、おかげさまで全て貼り付けられるようになりました。
ここまで丁寧に教えていただいてなんとお礼を申し上げたらいいかわかりません。本当にありがとうございます。

お礼日時：2008/09/02 10:56