- ベストアンサー
エクセルVBAをつかってフォルダ内のファイルの特定シートのデータを1つのシートにまとめる
はじめまして。 過去ログ検索しましたが、載っていないようなので投稿させていただきます。 ブックAがあるフォルダ内にある「○年*.xls」のさらに「○月(○月以外のシートもあり)」のシート内の特定のセル(範囲は固定されてます)の文字列を、全てブックAの1つのシートにまとめたいのですが、VBAにてこれは可能ですか? フォルダ内のファイルが複数だったり、またそのファイル内の該当シートが1つだったり複数だったりで、かなり行き詰ってます。 どなたかご存知の方いらっしゃいましたらご教授願います。 エクセル2000を使用しております。
- みんなの回答 (6)
- 専門家の回答
質問者が選んだベストアンサー
ANo.4です。 セル範囲とは1セル(1行)だったのですね。 ならばエラーになりますね。 >Set r = r.End(xlDown).Offset(1) 1行ずつ移動させるのでしたら、 Set r = r.Offset(1) でよろしいかと。 ついでですが、 >If InStr(ws.Name, "*年*月*") Then で問題は出ていませんか? こちらではシートを見つけられずデータが貼り付きません。 If InStr(ws.Name, "年") * InStr(ws.Name, "月") Then このように致しました。
その他の回答 (5)
- n-jun
- ベストアンサー率33% (959/2873)
ANO.5です。 >セル範囲は複数です。 >基本(A2:D30)の値のみを貼り付けられるように 提示されたコードとの食い違いがありますが。。。 複数であればANo.5での変更は必要ないです。 或いは、 Set r = r.Offset(r.Rows.Count) ですか。 コードは貼り付ける位置がA1からですが、これが別のセルを基準となるのなら、 適宜修正願います。
お礼
なかなかうごかなかったので、とりあえず一行で動かしてました。 ですが、おかげさまで全て貼り付けられるようになりました。 ここまで丁寧に教えていただいてなんとお礼を申し上げたらいいかわかりません。本当にありがとうございます。
- n-jun
- ベストアンサー率33% (959/2873)
ANo.3です。 >デバッグすると2周目の「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 こんな感じです。 もしかしたらパスやファイル名の指定に問題があるのかも・・・ ファイル名、シート名には法則があるので(ファイル名には「年」、シート名には「年.月」が必ず入ります)その辺は問題ないと思うのですが・・・。 何度もお手数おかけしてしまって申し訳ないです。
- n-jun
- ベストアンサー率33% (959/2873)
ANo.1です。 >>Set r = r.End(xlDown).Offset(1) >の(1)は消してもよかったんですよね?消さないと動かなかったもので・・・ 消していいものではありませんけど。 消すと貼り付けたデータの最終行に次のデータが貼り付いてしまい、 1行足りなくなります。 >あと、ちゃんと取り出したいデータを貼り付けてくれるのですが、全てA1に貼り付けされてしまい、 >結局最後に開かれたデータがA1に貼り付けられて終わってしまうのですが、このような場合はどうしたらよいでしょうか? 上記【Set r = r.End(xlDown).Offset(1)】がA1以降の行に順次貼り付けていくためのコードです。 検証した範囲では問題なく動いていましたが。。。
お礼
ありがとうございます。 今はフォルダ内に2つの該当ファイル、両方とも該当シートが2つある状況でテストしています。 とりあえず、コードはそのまま(1)を消さずに動いていますが、どうしても2週目で止まってしまいます。 1週目はちゃんと貼り付けてくれるんですけどね・・・。 でもこんなに丁寧に解説してくれて本当に助かります。 ありがとうございます!
補足
度々すいません。 デバッグすると2周目の「Set r = r.End(xlDown).Offset(1)」で止まってしまうという意味です。 「アプリケーション定義またはオブジェクト定義のエラーです」と表示されてしまいます。
- hana-hana3
- ベストアンサー率31% (4940/15541)
>過去ログ検索しましたが、載っていないようなので投稿させていただきます。 基本になる部分は過去ログでもエクセルのサンプルが載ったHPでも沢山あると思いますよ。 柔軟に利用できる知識があれば参考にして自力で基本部分は出来るはずです。 >フォルダ内のファイルが複数だったり、またそのファイル内の該当シートが1つだったり複数だったりで、かなり行き詰ってます。 どんな状態になっているのか解りませんが、文字列関数を利用してチェックすれば一定の選択は可能です。 条件から外れる場合はそれなりのチェックや抽出を行う仕組みにすれば良いでしょう。
- n-jun
- ベストアンサー率33% (959/2873)
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に貼り付けられて終わってしまうのですが、このような場合はどうしたらよいでしょうか? 私も自分で調べてみます。 ご丁寧にありがとうございます。本当に助かります。
お礼
返事が送れてすいません。 わざわざ本当にありがとうございます。 助かります。 セル範囲は複数です。 基本(A2:D30)の値のみを貼り付けられるように今現在色々と調べているところです。 ご丁寧にお答えいただきありがとうございました。