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

Question

現在、下記の方法で複数のブックからデータを抽出し、一覧表示をしています。（一覧表示をしているブックを仮にＡとします。）今のままだと、同一フォルダ内のブックしか抽出されません。これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか？簡単に例をあげると、フォルダ（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 です。いいお知恵があれば、よろしくお願い致します。

Wendy02 · Accepted Answer

こんばんは。ご自身のコードではありませんね。 >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

Wendy02 · Answer

こんばんは。

返事が遅くなりました。

以下を試してみてください。意味のない部分がありました。
良く見ると、この部分が余分のようです。

Set objFs = Nothing　　　'

ダメだったら、もう一度、コードを全部書き直します。

----------------------------------------

No.3 のコードの

Function MyFileSearch　の部分の、

　　Next
　　MyFileSearch = fCount
'×　Set objFs = Nothing　　　'←ここを抜いてください。
　　Exit Function
ErrHandler:
　　MyFileSearch = -1
End Function

-------------------------------------------

Wendy02 · Answer

こんぱんは。

>ここを、シート名可と書いていただいていたので
>シート名に変えてみたら、書き出し出来ました！
>あ～もう　本当にありがとうございました。

やはりそうでしたか。それでも、良く気が付きましたね。
そこは、私の経験で、ちょっと不安だったのです。

　Const mSH_NO As Variant = 5　　 'コピー先シート（シート名可)
　Const oSH_NO As Variant = 5　　 'コピー元シート ( '' )

実は、ここの部分を数字で置くというのは、失敗が多いのです。この数字は、ワークシートのシートタブの左から数えて、何枚目という数です。

最初にも書いたように、ここのBooks の引数に数字を入れることも同じです。

Workbooks(Workbooks.Count)

開いた何番目という意味で、こちらには、その間に割り込むことはないのですが、シートに関しては、私は、もう何年もマクロを書いていても、失敗しそうな気がします。

Wendy02 · Answer

こんにちは。今みると、少し雑になってしまいました。 >どういうわけか、コピー先ブック（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行目ですが、間違いないのですか？

Wendy02 · Answer

こんにちは。

>ReDim Preserve arFiles(fCount)
>ここでコンパイルエラー：変数が定義されていません。
>と出てきます。

それは、おそらく、以下の三行が、モジュールの一番上に書かれていないからだと思います。

Dim objFs As Object
Dim arFiles() As Variant
Dim fCount As Long

mitarashi · Answer

下位フォルダーのファイルリストが取得できれば良いのなら、物置に入っていたコードを提供します。試しに実行してみると、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

n-jun · Answer

FileSystemObject
http://www.officetanaka.net/excel/vba/filesystemobject/index.htm

こちらを参考に書き直せばできるかも？

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

こんばんは。

この回答への補足

こんばんは。

こんぱんは。

この回答への補足

こんにちは。

この回答への補足

こんにちは。

この回答への補足

下位フォルダーのファイルリストが取得できれば良いのなら、物置に入っていたコードを提供します。

FileSystemObject

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング