エクセル 複数ファイルから特定のデータを抽出

質問

いつもこちらでお世話になっております。

先日も同じような質問をさせて頂いたのですが、
ファイルの構成が変わってきてしまい、再度質問させて頂きます。

（元データ）
A　　B　　　　　C　　　　　　Ｄ　　　　　　　　Ｅ
No　月1　　　　月2　　　　　月2　　　　　　氏名　　　
1　2010/11　　2010/8　　　2010/7　　　　佐藤
2　2010/10　　2010/8　　　2010/7　　　　山田
3　2011/12　　2010/8　　　2010/7　　　　田中
4　2010/10　　2010/8　　　2010/7　　　　田中
・
・
上記のデータが１年度あたり
ファイル1（4シート+一覧シート）
ファイル2（4シート+一覧シート）
ファイル3（4シート+一覧シート）
ファイル4（4シート+一覧シート）
ファイル5（4シート+一覧シート）
※上記Ａ列のＮｏは1シート内での連番。

のように構成され、それが６年度分（計30ファイル）あるという状態です。

別ファイルにて2010/10とセルに入力してやると、各ファイルのＢ～Ｄ列に2010/10
とあるデータだけ抽出して一覧にしてくれるようにしたいと考えております。
関数またはVBAにて処理する方法はありますでしょうか？
お知恵を拝借願えれば幸いです。

回答No.3

merlionXX · ベストアンサー

ここがデバッグで黄色になったのであれば、対象ファイルのなかにE列以降にまったくデータのないシートがあるということですね。
そういうシートもあるのなら、手当てをしておけばすみます。

で、当初のB:D列ではなく、本当はE:G列を検索するのですね？
そのように直しました。

Sub test02()
　　Dim wb(1) As Workbook '変数宣言
　　Dim ws(2) As Worksheet
　　Dim myFl As String, MyPt As String
　　Dim myTg
　　Dim i As Long
　　Dim myC As Range

　　Set wb(0) = ThisWorkbook
　　Set ws(0) = wb(0).Sheets("Sheet1")
　　Set ws(1) = Sheets.Add(after:=Sheets(wb(0).Sheets.Count)) 'シート追加

　　MyPt = wb(0).Path & "\" '自分のパスを取得
　　myFl = Dir(MyPt & "*.xls", vbNormal) 'パス内のエクセルファイル
　　Application.ScreenUpdating = False '画面更新停止
　　myTg = ws(0).Range("A1").Value '検索年月
　　Do While myFl <> "" 'エクセルBOOKがなくなるまで
　　　　If myFl <> wb(0).Name Then '自分以外のファイルを対象
　　　　　　Set wb(1) = Workbooks.Open(MyPt & myFl) '選択したBOOKを開く
　　　　　　For Each ws(2) In wb(1).Worksheets '開いたBOOKの各シート
　　　　　　　　With ws(2)
　　　　　　　　　　If .UsedRange.Cells(.UsedRange.Count).Column > 4 Then　 'E列以降にデータがあれば
　　　　　　　　　　　　For Each myC In Intersect(.Range("E:G"), .UsedRange) 'E:G列
　　　　　　　　　　　　　　If myC.Value = myTg Then '検索年月があったら
　　　　　　　　　　　　　　　　i = i + 1 'カウント
　　　　　　　　　　　　　　　　myC.EntireRow.Copy ws(1).Rows(i) 'その行を追加したシートにコピペ
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next myC
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　Next ws(2)
　　　　　　wb(1).Close (False) '選択したファイルを閉じる
　　　　End If
　　　　myFl = Dir() '次のファイルを検索
　　Loop '繰り返し
　　Application.ScreenUpdating = True '画面更新停止解除
End Sub

回答No.2

merlionXX

すみません、ミスタイプです。

VBAコード、11行目

（誤）　MyPth = wb(0).Path & "\" '自分のパスを取得

（正） MyPt = wb(0).Path & "\" '自分のパスを取得

訂正します。

お礼

お礼が遅くなってしまい申し訳ありませんでした。
教えて頂いたＶＢＡを本ファイルに適用してみたのですが、
実行すると「オブジェクトが必要です」と出てしまい、

For Each myC In Intersect(.Range("E:G"), .UsedRange) 'E:G列

この行が黄色くなってしまいます。

※本ファイルに適用するために列名を変えております。

マクロはかなり初心者で、色々と調べてみたのですが
どこを直せば解消されるのかがわかりませんでした。
原因等、思い当たることがありましたらお教え願えれば幸いです。

回答No.1

merlionXX

> 先日も同じような質問をさせて頂いたのですが、

その質問が今回の質問への回答上、参考にしたほうが良いのなら、その質問にリンクさせるなり、すくなくとも質問番号くらいは書いた方がいいです。
わたしはその質問を探せませんでしたので今回の質問にのみ対応しました。

> 別ファイルにて2010/10とセルに入力してやると、

これも曖昧です。
別ファイルとは、マクロを書いたBOOKという理解でよいですか？
わからないのでその前提でいきます。
その別ファイルのどこに2010/10が入力してあるのですか？
これもわからないのでSheet1のA1セルに入力されたものとします。
それから2010/10とセルに入力したら、文字列ではない限り2010/10/1とか、Oct-10とかの表示に化けるのではないですか？
日付として入力されたものが書式による表示で2010/10としてあるのですか？

>　データだけ抽出して一覧にしてくれるようにしたい

どこに抽出するのですか？
不明な点ばかりですが、マクロを書いた別ファイルにあらたにシートを追加して、そこに抽出させるようにしてみました。

その30件くらいの検索対象のBOOKが入っているフォルダーに以下のマクロを書いたエクセルBOOK（転記先となる別ファイル）を保存してください。（パス取得のため、必ず「保存」が必要です。）
そのフォルダー内には検索対象のBOOKと、このマクロを書いたBOOKしかないものとします。

以下は標準モジュールに記述してください。

Sub test01()
　　Dim wb(1) As Workbook '変数宣言
　　Dim ws(2) As Worksheet
　　Dim myFl As String, MyPt As String
　　Dim myTg
　　Dim i As Long
　　Dim myC As Range

　　Set wb(0) = ThisWorkbook
　　Set ws(0) = wb(0).Sheets("Sheet1")
　　Set ws(1) = Sheets.Add(after:=Sheets(wb(0).Sheets.Count)) 'シート追加

　　MyPth = wb(0).Path & "\" '自分のパスを取得
　　myFl = Dir(MyPt & "*.xls", vbNormal) 'パス内のエクセルファイル
　　Application.ScreenUpdating = False '画面更新停止
　　myTg = ws(0).Range("A1").Value '検索年月
　　Do While myFl <> "" 'エクセルBOOKがなくなるまで
　　　　If myFl <> wb(0).Name Then '自分以外のファイルを対象
　　　　　　Set wb(1) = Workbooks.Open(MyPt & myFl) '選択したBOOKを開く
　　　　　　For Each ws(2) In wb(1).Worksheets '開いたBOOKの各シート
　　　　　　　　With ws(2)
　　　　　　　　　　For Each myC In Intersect(.Range("B:D"), .UsedRange) 'B:D列
　　　　　　　　　　　　If myC.Value = myTg Then '検索年月があったら
　　　　　　　　　　　　　　i = i + 1 'カウント
　　　　　　　　　　　　　　myC.EntireRow.Copy ws(1).Rows(i) 'その行を追加したシートにコピペ
　　　　　　　　　　　　End If
　　　　　　　　　　Next myC
　　　　　　　　End With
　　　　　　Next ws(2)
　　　　　　wb(1).Close (False) '選択したファイルを閉じる
　　　　End If
　　　　myFl = Dir() '次のファイルを検索
　　Loop '繰り返し
　　Application.ScreenUpdating = True '画面更新停止解除
End Sub

補足

回答ありがとうございました。

> 先日も同じような質問をさせて頂いたのですが・・
失礼致しました、先日の質問はこちらになります。
http://oshiete.goo.ne.jp/qa/6277479.html

> 別ファイルにて2010/10とセルに入力してやると、
その前提で問題ありません。
シリアル値をyyyy/mと書式設定しています。

>　データだけ抽出して一覧にしてくれるようにしたい
抽出先は2010/10と入力した同一ファイル（同一シート、別シートの拘りはありません。）
となります。