VBAにて複数フォルダのエクセルファイルからデータ抽出を行いたいのですが…

質問

現在、下記の方法で複数のブックからデータを抽出し、
一覧表示をしています。（一覧表示をしているブックを仮にＡとします。）
今のままだと、同一フォルダ内のブックしか抽出されません。
これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか？

簡単に例をあげると、
フォルダ（1）の中にＡを入れておいて
フォルダ（1）の下にあるサブフォルダ（1）、サブフォルダ（2）の中にあるブックからデータの抽出を行いたいのです。

現在つかっているVBAは
Sub 抽出用()
Dim FName As String
Dim Folder As String
Dim wb As Workbook
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
Folder = ThisWorkbook.Path & "\"
i = 1: j = 1
Worksheets(1).Cells.ClearContents
FName = Dir(Folder & "*.xls")
Do While FName <> ""
If FName <> ThisWorkbook.Name Then
Workbooks.Open (Folder & FName)
Workbooks(Workbooks.Count).Worksheets(5).Rows("1:1").Copy _
ThisWorkbook.Worksheets(5).Cells(i + 3, 1)
Workbooks(Workbooks.Count).Close
Application.StatusBar = j & "ファイル処理済み"
i = i + 1: j = j + 1
End If
FName = Dir()
Loop
Application.StatusBar = ""
Application.ScreenUpdating = True
MsgBox ("完了しました")

End Sub

です。
いいお知恵があれば、よろしくお願い致します。

回答No.3

Wendy02 · ベストアンサー

こんばんは。

ご自身のコードではありませんね。
>Workbooks(Workbooks.Count)
問題は発生しないけれども、せっかく、前のコードで、オブジェクトを取得しているのですから、それを新たにオブジェクトを取るのはよくないです。たぶん、癖だと思いますが、これは直したほうがよいでしょうね。

なお、シート元が存在しないときのエラーについては、On Error Resume Next ですから、そのまま進んでしまいます。コピー先のシートが存在しない場合は、アクティブシートにコピーされます。本来は、Index を使用せずに、明示的なシート名を使ったほうがよいとは思いますが、それはVariant ですから、選択の自由にしてあります。

ファイル数が、極端に多いと、おそらく、途中で、メモリがなくなるように思います。指定フォルダのミスを含めて、LIMITでオープンファイル数の制限を設けたら良いかと思います。
'---------------------------------------------

Dim objFs As Object
Dim arFiles() As Variant
Dim fCount As Long
Sub ExctactingData()
　　Dim FName As String
　　Dim myFolder As String
　　Dim wb As Workbook
　　Dim i As Long
　　Dim j As Long
　　Dim fn As Variant
　　Dim myBook As Workbook
　　Dim ret As Long
　　'
　　Set objFs = Nothing 'オブジェクトの初期化
　　Erase arFiles '配列の初期化
　　fCount = 0 'ファイルカウントの初期化
　　''-----------------------------
　　'User Setting
　　Set myBook = ThisWorkbook　　　 'コピー先ブック
　　myFolder = myBook.Path & "\"　　'検索フォルダ
　　Const mSH_NO As Variant = 5　　 'コピー先シート（シート名可)
　　Const oSH_NO As Variant = 5　　 'コピー元シート ( '' )
　　i = 4　　　　　　　　　　　　　 '書き出す最初の行
　　Const LIMIT As Integer = 500　　 'ファイルオープン・限界数
　　''-----------------------------

　　If Dir(myFolder) = "" Then
　　　 MsgBox myFolder & " は存在しません。", vbQuestion
　　　 Exit Sub
　　End If

　　On Error Resume Next
　　'Application.ScreenUpdating = False
　　'データの消去
　　If WorksheetFunction.Count(myBook.Worksheets(mSH_NO).Cells) > 1 Then
　　　 If MsgBox("既にデータがありますが、削除してよろしいですか？", vbQuestion + vbOKCancel) = vbOK Then
　　　　　 myBook.Worksheets(mSH_NO).Cells.ClearContents
　　　 Else
　　　　　 Exit Sub
　　　 End If
　　End If

　　'ファイルシステム・オブジェクトの生成
　　Set objFs = CreateObject("Scripting.FileSystemObject")

　　fCount = MyFileSearch(myFolder, FName, fCount)
　　If ret > -1 Then
　　If fCount > LIMIT Then
　　　 If MsgBox("ファイル数が" & fCount & " です。トラブルを起こす可能性がありますが、続行しますか？", vbInformation + vbOKCancel) = vbCancel Then
　　　　 Set objFs = Nothing
　　　　　Exit Sub
　　　 End If
　　End If
　　For Each fn In arFiles
　　Debug.Print fn
　　　　If fn <> myBook.Name Then
　　　　With Workbooks.Open(fn)
　　　　　　.Worksheets(oSH_NO).Rows(1).Copy myBook.Worksheets(mSH_NO).Cells(i, 1)
　　　　　　 .Close False
　　　　　　 i = i + 1
　　　　End With
　　　　End If
　　 Next
　　 End If
　　'Application.ScreenUpdating = True
　　Set objFs = Nothing
　　If fCount > -1 Then
　　　　MsgBox fCount & " 個のファイルを完了しました", vbInformation
　　Else
　　　　MsgBox "エラーが発生して、ファイル名が取得できませんでした。", vbCritical
　　End If

End Sub

Function MyFileSearch(strDir As String, strFile As String, fCount As Long) As Long
　　On Error GoTo ErrHandler
　　Const EXT As String = "*.xl?"　'拡張子の指定
　　Dim objDir As Object
　　Dim objFile As Object
　　Set objDir = objFs.Getfolder(strDir)
　　Set objFile = objDir.Files
　　For Each objFile In objDir.Files
　　　　If objFile Like EXT Then
　　　　　　ReDim Preserve arFiles(fCount)
　　　　　　arFiles(fCount) = objFile.Path
　　　　　　fCount = fCount + 1
　　　　End If
　　Next
　　For Each objDir In objDir.SubFolders
　　　　If objDir.Attributes <> 22 Then
　　　　　　Call MyFileSearch(objDir.Path, strFile, fCount)
　　　　End If
　　Next
　　MyFileSearch = fCount
　　Set objFs = Nothing
　　Exit Function
ErrHandler:
　　MyFileSearch = -1
End Function

補足

ピンポイントのご回答、大変ありがとうございます。
ご指摘のとおり、私のコードでは無いですし
VBAは全くもって初心者です。
しかし、なんとか使いやすく。。。と、試行錯誤しております。

そんな中、こんなにご丁寧な回答をいただいて、とても嬉しいのですが、
ReDim Preserve arFiles(fCount)
ここでコンパイルエラー：変数が定義されていません。
と出てきます。
これは、どうすればいいのでしょう？
よろしくお願い致します。

回答No.7

Wendy02

こんばんは。

返事が遅くなりました。

以下を試してみてください。意味のない部分がありました。
良く見ると、この部分が余分のようです。

Set objFs = Nothing　　　'

ダメだったら、もう一度、コードを全部書き直します。

----------------------------------------

No.3 のコードの

Function MyFileSearch　の部分の、

　　Next
　　MyFileSearch = fCount
'×　Set objFs = Nothing　　　'←ここを抜いてください。
　　Exit Function
ErrHandler:
　　MyFileSearch = -1
End Function

-------------------------------------------

お礼

ありがとうございます！完璧に探して書き出ししてくれてます！
Function MyFileSearch部分のどこかを何かするんだろうな
と思って、いろいろやってみていたんですが
まさか抜くだけだったなんて。。。
本当に最後の最後まで、お付き合い頂きありがとうございました。
助かりました。
頭痛から解放されました(笑)
ありがとうございました！

回答No.6

Wendy02

こんぱんは。

>ここを、シート名可と書いていただいていたので
>シート名に変えてみたら、書き出し出来ました！
>あ～もう　本当にありがとうございました。

やはりそうでしたか。それでも、良く気が付きましたね。
そこは、私の経験で、ちょっと不安だったのです。

　Const mSH_NO As Variant = 5　　 'コピー先シート（シート名可)
　Const oSH_NO As Variant = 5　　 'コピー元シート ( '' )

実は、ここの部分を数字で置くというのは、失敗が多いのです。この数字は、ワークシートのシートタブの左から数えて、何枚目という数です。

最初にも書いたように、ここのBooks の引数に数字を入れることも同じです。

Workbooks(Workbooks.Count)

開いた何番目という意味で、こちらには、その間に割り込むことはないのですが、シートに関しては、私は、もう何年もマクロを書いていても、失敗しそうな気がします。

補足

おはようございます。
シートに数字を置くってやっかいなことなんですねぇ。
勉強になりました。ありがとうございます。

で、回答番号No.5にお礼をつけてしまってから気がついたのですが
書き出しはしてくれたのですが、検索するサブフォルダが
サブフォルダ（1）とサブフォルダ（2）とかのように
2個以上になると、サブフォルダ（1）の中の分しか書き出しされません。
これは何故でしょう。。。
もしも何かお知恵があればよろしくお願い致します。
本当に度々申し訳ございません。

回答No.5

Wendy02

こんにちは。

今みると、少し雑になってしまいました。

>どういうわけか、コピー先ブック（ThisWorkBook）も検索されて二重に開いてしまうのと、

'　Debug.Print fn　'←ここに「'(アポストロフィー)」を入れてください。

　If fn <> myBook.Name Then　原因は、これが生きていません。
しかし、ユーザー定義関数で、修正したほうが早いようです。

----------------------------------------
Function MyFileSearch の中の

For Each objFile In objDir.Files
　　　　If objFile Like EXT And objFile.Name <> ThisWorkbook.Name Then '○
　　　　　　ReDim Preserve arFiles(fCount)
　　　　　　arFiles(fCount) = objFile.Path
　　　　　　fCount = fCount + 1
　　　　End If
　　Next

○の部分を以上のように、If objFile Like EXT の後に、objFile.Name <> ThisWorkbook.Name　を入れてください。

----------------------------------------
>ファイルの個数は、サブフォルダも含めきちんとカウントされているのですが、
>コピー先シートへ抽出結果が書き出されないのです。

　MsgBox fCount & " 個のファイルを完了しました", vbInformation
このメッセージは出ているようですね。

　Const mSH_NO As Variant = 5　　 'コピー先シート（シート名可)
　Const oSH_NO As Variant = 5　　 'コピー元シート ( '' )

この oSH_NO が正しく入れられていないのか、ファイルの取得では、エラーが発生していないようですから、途中で、止めて調べてみるしかありません。

　　　　With Workbooks.Open(fn)
　　　　　　'MsgBox .Name & "!" & .Worksheets(oSH_NO).Name
**　　　　　.Worksheets(oSH_NO).Rows(1).Copy myBook.Worksheets(mSH_NO).Cells(i, 1)
　　　　　 .Close False　

**のところに、カーソルを置いて、F9 を押すと、●と茶色等のパターンで文字が反転しブレークポイントが入ります。そこでマクロを実行すると、そこでとまります。もし、とまらないようなら、エラーが発生しています。

その上で、 MsgBox .Name & "!" & .Worksheets(oSH_NO).Name　を入れて、確認してみると良いです。
マクロの中断は、Ctrl + Break で、マクロがとまります。

なお
　.Worksheets(oSH_NO).Rows(1).　←1行目ですが、間違いないのですか？

お礼

出来ましたっ！！
Const mSH_NO As Variant = 5　　 'コピー先シート（シート名可)
ここを、シート名可と書いていただいていたので
シート名に変えてみたら、書き出し出来ました！
あ～もう　本当にありがとうございました。
こんなに嬉しいことはないです。
心から感謝しております。
ありがとうございました。

補足

ご丁寧な回答、本当にありがとうございます。
お陰さまで、一点目の
>コピー先ブック（ThisWorkBook）も検索されて二重に開いてしまう
については、解決しました。

二点目の
>コピー先シートへ抽出結果が書き出されない
につきましても、ご指示いただいたように試してみました。
結果は
ブレークポイントで止まり、確かに1行目に抽出されるべきデータがあり、
メッセージボックスにもファイル名と、シート名が表示されましたが
書き出しが出来ませんでした。

なんだか申し訳なく思うのですが、なにか思いつくことがあれば
ご指示くださいますようお願い致します。
本当にすみません。

回答No.4

Wendy02

こんにちは。

>ReDim Preserve arFiles(fCount)
>ここでコンパイルエラー：変数が定義されていません。
>と出てきます。

それは、おそらく、以下の三行が、モジュールの一番上に書かれていないからだと思います。

Dim objFs As Object
Dim arFiles() As Variant
Dim fCount As Long

お礼

回答番号No.5にお礼をつけてしまってから気がついて、
こちらに書かせていただきます。ごめんなさい。
書き出しはしてくれたのですが、検索するサブフォルダが
サブフォルダ（1）とサブフォルダ（2）とかのように
2個以上になると、サブフォルダ（1）の中の分しか書き出しされません。
これは何故でしょう。。。
もしも何かお知恵があればよろしくお願い致します。
本当に度々申し訳ございません。

補足

すいません。抜けてました。。。
お陰さまで、コンパイルエラーは出なくなりましたが、
どういうわけか、コピー先ブック（ThisWorkBook）も検索されて
二重に開いてしまうのと、
ファイルの個数は、サブフォルダも含めきちんとカウントされているのですが、
コピー先シートへ抽出結果が書き出されないのです。
自分でわかる範囲は。。。と思い、ずっと見ていってるのですがわかりません。
本当にお世話をかけますが、再度よろしくお願い申し上げます。

回答No.2

mitarashi

下位フォルダーのファイルリストが取得できれば良いのなら、物置に入っていたコードを提供します。試しに実行してみると、My Documentsの22875個のファイルのリスト読込に1分、読み取った情報のdebug.printに4分30秒くらいかかりました。
Dim fileList As Collection
Dim FSO As Object

Sub searchFolder()
Dim folderName As String
Dim i As Long

folderName = "C:\Documents and Settings\?????\My Documents"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set fileList = New Collection
Call searchSubFolder(FSO.GetFolder(folderName))

For i = 1 To fileList.Count
With fileList(i)
Debug.Print i;
Debug.Print .Path;
Debug.Print .DateLastModified
End With
Next
Set FSO = Nothing
End Sub

Private Sub searchSubFolder(parentFolder As Object)
Dim subFolder As Object
Dim myFile As Object

For Each subFolder In parentFolder.SubFolders
Call searchSubFolder(subFolder)
Next subFolder

For Each myFile In parentFolder.Files
fileList.Add Item:=myFile
Next myFile
Set parentFolder = Nothing
End Sub

お礼

ご回答ありがとうございます。
今やりたいことから、少し外れているようなのですが、
これはこれで是非とも参考にさせていただきます。
ありがとうございました。

回答No.1

n-jun

FileSystemObject
http://www.officetanaka.net/excel/vba/filesystemobject/index.htm

こちらを参考に書き直せばできるかも？

お礼

ご回答ありがとうございます。
FileSystemObjectは、どこかでEXCEL2000～2003が対象で。。。
とかいうコメントを、どこかで読んだ気がして
調べなかったのです。
でも、ご指示いただいたページを拝見したら
参考になりそうな箇所を見つけましたので、他のご回答も試してみてから、じっくり拝見したいと思います。
ありがとうございました。