エクセル 複数ファイルから特定のデータを一覧に

質問

エクセル　複数ファイルから特定のデータを一覧に

先日こちらで質問をさせて頂いたのですが、うまく解決できず
、またその後独力でも解決できないので、再度質問させて頂きます。

前質問
http://okwave.jp/qa/q6309713.html

（元データ）
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ファイル）あるという状態です。

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

回答No.3

merlionXX · ベストアンサー

> 上記式にて問題なく実行できました。

原因は何だったのか、日付が違っていた、時間が入っていた等、具体的に書いていただけると、ありがたいのですが。

> "sheet2"の"3"行目以降に、元のデータの"A～Z列"をコピペしろ
> という形にするには上記式の変更で済みますでしょうか？

もちろん出来ますよ。
その際、Sheet2"の"3"行目以降にデータがあっても上書きしてかまわないのですか？
特にご指定がないので上書きさせます。（そうすると転記したデータと、前からあったデータの区別がつかなくなりそうですが・・。まあ、そういう心配がないから指定がないものと推察します。）

Sub test04()
　　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) = wb(0).Sheets("Sheet2")

　　MyPt = wb(0).Path & "\"
　　myFl = Dir(MyPt & "*.xls", vbNormal)
　　Application.ScreenUpdating = False
　　myTg = ws(0).Range("A1").Value
　　i = 3 '3行目指定
　　Do While myFl <> ""
　　　　If myFl <> wb(0).Name Then
　　　　　　Set wb(1) = Workbooks.Open(MyPt & myFl)
　　　　　　For Each ws(2) In wb(1).Worksheets
　　　　　　　　With ws(2)
　　　　　　　　　　If .Name <> "一覧" And .Name <> "作業用シート" Then
　　　　　　　　　　　　If .UsedRange.Cells(.UsedRange.Count).Column >= 4 Then
　　　　　　　　　　　　　　For Each myC In Intersect(.Range("E:G"), .UsedRange)
　　　　　　　　　　　　　　　　If IsDate(myC.Value) Then
　　　　　　　　　　　　　　　　　　If Format(myC.Value, "yyyy/mm") = Format(myTg, "yyyy/mm") Then
　　　　　　　　　　　　　　　　　　　　myC.EntireRow.Cells(1).Resize(, 26).Copy 'A-Z列コピー
　　　　　　　　　　　　　　　　　　　　ws(1).Cells(i, 1).PasteSpecial
　　　　　　　　　　　　　　　　　　　　ws(1).Cells(i, 1).PasteSpecial Paste:=xlPasteValues
　　　　　　　　　　　　　　　　　　　　i = i + 1 'カウント
　　　　　　　　　　　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　Next myC
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　Next ws(2)
　　　　　　wb(1).Close (False)
　　　　End If
　　　　myFl = Dir()
　　Loop
　　Application.ScreenUpdating = True
End Sub

お礼

本当にありがとうございました。
上記ＶＢＡにてやりたいことが全て実行されました。

長々とお付き合い頂き誠にありがとうございます。

＞原因は何だったのか、日付が違っていた、時間が入っていた等、具体的に書いていただけると、ありがたいのですが。
尚、こちらに関しまして、実は原因がよく分かりませんでした。
元ファイル及び、検索用ファイルの年月欄の書式を変えてみて
検証したのですが、合致したものだったので。。

＞その際、Sheet2"の"3"行目以降にデータがあっても上書きしてかまわないのですか？
こちらに関しては、確かに仰るように分かりづらくなってしまうので、
勝手に作成頂いたＶＢＡに３行目以降をまず消す処理を加えさせて頂きました。
稼動は問題ないので、多分大丈夫かと思います。

また、VBAは初心者なのですが、丁寧に書いて頂いたことで
非常に勉強になりました。

重ねて御礼申し上げます。

回答No.2

merlionXX

> ここで重ねて質問させて頂きます。

わかりました。では前回の質問は締め切ってください。

> 参照するE:G列の年月（oooo/oo）は実は他の入力した数値から関数で
出している数字なのですが、参照先が関数式の場合、A1セルと合致している
年月としてみなされないのでしょうか？

そんなことはないです。
直接入力している列を参照させてうまくいったのならコードは正しいと思います。しかし関数表示の方がマッチしないなら関数で表示されたデータを確認してみてください。
関数でoooo/oo　と表示さたセルを他のセルで参照してみて、そのセル書式をyyyy/m/d h:mmにしたらどう出ますか？
A1セルの書式も同じyyyy/m/d h:mm にして比べてください。
yyyy/mmだけの表示だと日が違って同じに見えるので厄介です。

もし、日付か時間が違うのなら、年と月だけで検索するようにコードを変更します。
あと、関数式だと前回のTEST02では正しくコピーされないので、これも変更しなくてはいけません。
それから、名前が"一覧"か"作業用シート"でないシートだけを対象にすればよいのですね？

Sub test03()
　　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 <> ""
　　　　If myFl <> wb(0).Name Then
　　　　　　Set wb(1) = Workbooks.Open(MyPt & myFl)
　　　　　　For Each ws(2) In wb(1).Worksheets
　　　　　　　　With ws(2)
　　　　　　　　　　If .Name <> "一覧" And .Name <> "作業用シート" Then '名前が"一覧"か"作業用シート"でなきゃ
　　　　　　　　　　　　If .UsedRange.Cells(.UsedRange.Count).Column > 4 Then
　　　　　　　　　　　　　　For Each myC In Intersect(.Range("E:G"), .UsedRange) '
　　　　　　　　　　　　　　　　If IsDate(myC.Value) Then '日付データなら
　　　　　　　　　　　　　　　　　　If Format(myC.Value, "yyyy/mm") = Format(myTg, "yyyy/mm") Then
　　　　　　　　　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　　　　　　　　　myC.EntireRow.Copy
　　　　　　　　　　　　　　　　　　　　ws(1).Rows(i).PasteSpecial
　　　　　　　　　　　　　　　　　　　　ws(1).Rows(i).PasteSpecial Paste:=xlPasteValues '値貼り付けに
　　　　　　　　　　　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　Next myC
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　Next ws(2)
　　　　　　wb(1).Close (False)
　　　　End If
　　　　myFl = Dir()
　　Loop '繰り返し
　　Application.ScreenUpdating = True
End Sub

お礼

早速のお返事本当にありがとうございました。

上記式にて問題なく実行できました。
大変助かりました。

厚かましくて恐縮なのですが、
最後にもうひとつだけお願いをさせて頂ければ幸いです。

始めに言うべきだったのですが、
最終的に引っ張ってきたデータをもとに関数処理させたい
部分があります。

新たなシートを作成せずに、
"sheet2"の"3"行目以降に、元のデータの"A～Z列"をコピペしろ
という形にするには上記式の変更で済みますでしょうか？

回答No.1

merlionXX

おや、今朝お書きになった「実行するとオブジェクトが必要ですと出てしまい、」という補足へ、さきほど再度回答したのですが、別に再質問されていたのですか・・・・。
(゜〇゜;)

ちょうどよい？機会ですので少しご説明します。
30ファイルの全シートに対して検索をかけたのですが、各シートの対象列の全行を見るのも非効率ですから、Ｂ～Ｄ列かつ使用範囲という限定をかけました。
ところが、多分、シートの中にはＢ列以降（実際は違うのでしたね）をまったく使用していないシートがあったのだと思います。そのためのエラーです。

ファイル1（4シート+一覧シート）
ファイル2（4シート+一覧シート）
ファイル3（4シート+一覧シート）
ファイル4（4シート+一覧シート）
ファイル5（4シート+一覧シート）

とお書きなので、そのうちの一覧シートというのがそうではないかと推測しますが、ご提供の情報だけでは他のシートとＢ列以降を使ってないシートを区別できないのです。
（たとえば一覧シートはかならずシート名の最後が「一覧」であり他のデータシートと区別できるとか、規則性があれば最初からそのシートは除いて検索できますが。）

そのような情報がないので、先ほどの質問への再回答は、その指定列以降にデータがないシートを除外するようにしてあります。
お試しください。

お礼

たびたびのご回答誠にありがとうございました。

上記VBAにて試させて頂いたところ、データがうまく表示されないので、
（新しいシートはできるが白紙のまま）
参照範囲などをいじっていたところ、もしやと思うことがあったので、
大変恐縮ですが、ここで重ねて質問させて頂きます。

■参照するE:G列の年月（oooo/oo）は実は他の入力した数値から関数で
出している数字なのですが、参照先が関数式の場合、A1セルと合致している
年月としてみなされないのでしょうか？

※直接入力している列を上記マクロにて参照させてみたところうまくいったので・・。

■
＞たとえば一覧シートはかならずシート名の最後が「一覧」であり他のデータシートと区別できるとか、規則性があれば最初からそのシートは除いて検索できますが。
こちらで仰って頂いたことに甘えての質問ですが・・・、
全てのファイルに必ず“一覧”及び“作業用シート”というものが存在しています。
これらを検索対象から外すにはどのような式を書いてやればいいのでしょうか？

お手数をかけて申し訳ないのですが、宜しくお願い致します。

補足

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