• ベストアンサー

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

現在、下記の方法で複数のブックからデータを抽出し、 一覧表示をしています。(一覧表示をしているブックを仮にAとします。) 今のままだと、同一フォルダ内のブックしか抽出されません。 これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか? 簡単に例をあげると、 フォルダ(1)の中にAを入れておいて フォルダ(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
  • ベストアンサー率57% (3570/6232)
回答No.3

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

coco-yo
質問者

補足

ピンポイントのご回答、大変ありがとうございます。 ご指摘のとおり、私のコードでは無いですし VBAは全くもって初心者です。 しかし、なんとか使いやすく。。。と、試行錯誤しております。 そんな中、こんなにご丁寧な回答をいただいて、とても嬉しいのですが、 ReDim Preserve arFiles(fCount) ここでコンパイルエラー:変数が定義されていません。 と出てきます。 これは、どうすればいいのでしょう? よろしくお願い致します。

すると、全ての回答が全文表示されます。

その他の回答 (6)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.7

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

coco-yo
質問者

お礼

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

すると、全ての回答が全文表示されます。
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.6

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

coco-yo
質問者

補足

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

すると、全ての回答が全文表示されます。
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.5

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

coco-yo
質問者

お礼

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

coco-yo
質問者

補足

ご丁寧な回答、本当にありがとうございます。 お陰さまで、一点目の >コピー先ブック(ThisWorkBook)も検索されて二重に開いてしまう については、解決しました。 二点目の >コピー先シートへ抽出結果が書き出されない につきましても、ご指示いただいたように試してみました。 結果は ブレークポイントで止まり、確かに1行目に抽出されるべきデータがあり、 メッセージボックスにもファイル名と、シート名が表示されましたが 書き出しが出来ませんでした。 なんだか申し訳なく思うのですが、なにか思いつくことがあれば ご指示くださいますようお願い致します。 本当にすみません。

すると、全ての回答が全文表示されます。
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.4

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

coco-yo
質問者

お礼

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

coco-yo
質問者

補足

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

すると、全ての回答が全文表示されます。
  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.2

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

coco-yo
質問者

お礼

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

すると、全ての回答が全文表示されます。
  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.1

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

coco-yo
質問者

お礼

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

すると、全ての回答が全文表示されます。

関連するQ&A

専門家に質問してみよう