[[20220222115644]]　『複数のフォルダーに入っているエクセルからデータ』（限界）　ページの最後に飛ぶ

『複数のフォルダーに入っているエクセルからデータをコピーする』（限界）

「あ」という名前のフォルダーがあります。
「あ」の中に複数のフォルダーがあります。
ここでは、フォルダー名を「ア」「イ」「ウ」とします。
さらに「ア」のフォルダーの中にエクセルが入っています。
ここでは、エクセル名を「Ａ」「Ｂ」「Ｃ」とします。
「Ａ」「Ｂ」「Ｃ」の中にあるsheet1からデータをコピーして、ひとつのエクセルに貼り付けしたいです。

フォルダ「あ」＞フォルダ「ア」＞エクセル「Ａ」＞sheet1　という作りです。

ダイアログを開くマクロを調べていたのですが、複数のフォルダーを選択するということはできないのでしょうか。
それであれば、とりあえず一つのフォルダーにエクセルを集めるというマクロを組んだらよいのかと思うのですが、どのようなマクロを作成したらよいのでしょうか。

よろしくおねがいいたします。

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

＞複数のフォルダーを選択するということはできないのでしょうか。
ファイルではなくフォルダですか？

＞「Ａ」「Ｂ」「Ｃ」の中にあるsheet1からデータをコピーして、ひとつのエクセルに貼り付けしたいです。
これがやりたいことなんですよね？
フォルダを選択する必要はあるのでしょうか

＞とりあえず一つのフォルダーにエクセルを集めるというマクロを組んだらよいのかと思うのですが
なぜそう思ったのですか。
実装したい内容について具体的に教えてください

なお、複数のファイルを選択できるようにするためには
GetOpenFilenameのmultiSelectプロパティをTrueにすれば実装できます。
（初心者A） 2022/02/22(火) 12:17

FileSystemFolderという外部ツール（簡単にVBAから利用できます）を使えば、
・指定したフォルダにあるサブフォルダのコレクションを得たり、
http://officetanaka.net/excel/vba/filesystemobject/folder14.htm
・指定したフォルダにあるすべてのファイルのコレクションを得たりすることができます。
http://officetanaka.net/excel/vba/filesystemobject/folder06.htm
これらを組み合わせば、「あ」フォルダ傘下の、サブフォルダたちの中にあるすべてのファイルを
取得できます。
　
FileSystemFolder全体の説明は、以下です。
http://officetanaka.net/excel/vba/filesystemobject/index.htm
　
また、そのページに「実用サンプル」のリンクもあります。
「サブフォルダの全ファイルサイズをグラフ化する」
http://officetanaka.net/excel/vba/filesystemobject/sample08.htm
「フォルダ内に存在する全「.xlsx」ファイルのベース名を取得する」
http://officetanaka.net/excel/vba/filesystemobject/sample07.htm
などが今回のテーマの参考になるでしょう。

（γ） 2022/02/22(火) 12:46

初心者Ａ様

ありがとうございます。

以前、一つのフォルダーに複数のエクセルを収納し、そのすべてのエクセルからデータをコピペするというマクロを実行していました。

やりたい行為としては、複数の「ファイル」からデータをコピペすることですが、ファイル名が定まっていない（後述）複数のエクセルを選択するには、フォルダーに入っている場所で指定するか、データを引用するエクセルを一つのフォルダーに収納しないとできないと思い込んでいました次第です。

ファイル名が定まっていないというのは、「あ」「い」「う」のフォルダーは日付ごとに新しく作成していて、中に入っているエクセル「Ａ」「Ｂ」「Ｃ」は名前が以前と同じだったり異なっていたり混在しているため、常にファイル名が一つに定まっていないという意味です。

よろしくお願いします
（限界） 2022/02/22(火) 12:51

「あ」の配下のサブフォルダを含めたファイル一覧を作成するサンプルです。
今回はファイル一覧の作成のところを「sheet1からデータをコピーして、ひとつのエクセルに貼り付ける」処理にすればいけると思います。

サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）
https://www.moug.net/tech/exvba/0060088.html

（めいぷる） 2022/02/22(火) 13:15

ありがとうございます。
サブフォルダーが「.」となってしまい、修正しようとしているのですが何が原因かわかりません。
どこを修正したらよいでしょうか。
全然だめだと思うのですが。。

Sub test()

    Worksheets("Sheet1").Range("A1:J100").Clear

    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
    Range("D1").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    End If

    Dim Folder_path
    Folder_path = ThisWorkbook.Worksheets("Sheet1").Range("D1").Value

    Dim subF As String
    subF = Dir(Folder_path & "\", vbDirectory)

    Dim FileType
    FileType = "\*.xlsm"

    Dim MergeWorkbook
    MergeWorkbook = Dir(Folder_path & "\" & subF & FileType)

        Do Until subF = ""

        If GetAttr(Folder_path & "\" & subF) And vbDirectory Then 
        If subF <> "." And subF <> ".." Then

        Workbooks.Open Filename:=Folder_path & "\" & subF & "\" & MergeWorkbook

        Dim MergeWorkbook_MaxRow As Long
        Dim MaxRow As Long

          MergeWorkbook_MaxRow = Workbooks(MergeWorkbook).Worksheets("表").Cells(Rows.Count, 1).End(xlUp).Row
          MaxRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

          If MaxRow = 2 Then
          Workbooks(MergeWorkbook).Worksheets("表").Range("A1").CurrentRegion.Copy _
          ThisWorkbook.Sheets("Sheet1").Cells(MaxRow + 2, 1)

          For m = 4 To MergeWorkbook_MaxRow + 1
          ThisWorkbook.Sheets("Sheet1").Range("J" & MaxRow + m) = MergeWorkbook
          Next

          Else
          Workbooks(MergeWorkbook).Worksheets("表").Range("A3").Select
          Range(Selection, Selection.End(xlToRight)).Select
          Range(Selection, Selection.End(xlDown)).Select
          Selection.Copy _
          ThisWorkbook.Sheets("Sheet1").Cells(MaxRow + 1, 1)

          For n = 3 To MergeWorkbook_MaxRow
          ThisWorkbook.Sheets("Sheet1").Range("J" & MaxRow + n - 2) = MergeWorkbook
          Next

          End If

        End If
        End If

　　　　'結合するブックを閉じる

        Application.DisplayAlerts = False
            Workbooks(MergeWorkbook).Close
        Application.DisplayAlerts = True

　　　　subF = Dir()

'次のブックを探しに行く

        MergeWorkbook = Dir()
    Loop

    Range("A1").Activate
End Sub

（限界） 2022/02/22(火) 18:25

・フォルダを取得するDir関数を使ったループと、
・フォルダ内のファイルを取得するDir関数のループを
同時に交差して使うことはできません。

いったんサブフォルダ名をすべて取得してから、
それぞれについて、ファイル名を取得する
というようにするか、FileSystemObjectを使うかです。

めいぷるさんの紹介されたサイトの記事も
サブフォルダの取得はFileSystemObjectを使っていたかと思います。
一行でサブフォルダのコレクションが得られるので、慣れれば簡単です。

Dir関数ももちろん必要な技術ですが、FileSystemObjectも是非トライされることを推奨します。

（γ） 2022/02/22(火) 19:00

 一例です。参考にしてみてください。
 特定のフォルダの傘下にある各サブフォルダ内の各Excelファイルを順次開きます。

 Sub test()
     Const folderpath As String = "D:\Mydocuments\202202"  '■要修正
     Dim fso   As Object
     Dim subf  As Object    'Folderオブジェクト
     Dim f     As Object    'File  オブジェクト
     Dim wb    As Workbook

     Set fso = CreateObject("Scripting.FileSystemObject")
     For Each subf In fso.GetFolder(folderpath).SubFolders
         For Each f In subf.Files
             Set wb = Workbooks.Open(f.Path)
             ' (省略)
             wb.Close False
         Next
     Next
     Set fso = Nothing
 End Sub

（γ） 2022/02/22(火) 19:49

＞サブフォルダーが「.」となってしまい、修正しようとしているのですが何が原因かわかりません。
この件に回答するのが先でしたか。

結論から言うと、そうした次々にフォルダを返すようなことはできません。仕様です。

Dir関数のヘルプを確認してください。
＞vbDirectory 属性を付けて Dir を呼び出しても、
＞継続してサブディレクトリが返されることはありません。
と書かれています。
つまり、ファイルを次々に列挙するのと同じように、サブフォルダを列挙することはできない、
ということです。

（γ） 2022/02/22(火) 21:17

 "." はそのディレクトリそのもの、".."はそのディレクトリの親ディレクトリです
 Dir関数でディレクトリを取得すると、その2つは必ず入ってくるので、処理から除外します

 Dir関数で、vbDirectoryを指定すると、ディレクトリとファイルの両方が列挙されるので
 ファイルかディレクトリかを調べて、ファイルを除外します。

  Dim f As String
  Path = "C:\Windows\"

  f = Dir(Path, vbDirectory)
  Do While f <> ""
    If GetAttr(Path & f) And vbDirectory Then
      If f <> "." And f <> ".." Then
         Debug.Print f
      End If
    End If
    f = Dir()
  Loop

 Dir関数は、更にディレクトリツリーを深掘りしてくれないし、いろいろ面倒ですね。
 Dir関数はレガシーなので、皆さんの指摘のように、他のもっと楽な方法を使う方がよいです
（´・ω・`） 2022/02/22(火) 22:02

質問者さんのコードを殆ど読んでいなかったことが丸わかりで、失礼しました。
大昔は書いていたような記憶がありますが、最近ではそうしたコードは全く使っていませんでした。
どうもどうも。

（γ） 2022/02/22(火) 22:20

 マナさんの方法（って勝手に呼んでますが）をつかったサンプルです 
 D:\test\　以下の *.xls* にマッチするファイルを列挙します
 サブフォルダも対象です

 Sub sample()
   Dim path As String, filename As Variant
   path = "D:\test\*.xls*"
   For Each filename In EnumFiles(path)
      Debug.Print filename
   Next
 End Sub

 Function EnumFiles(path As String) As String()
   With CreateObject("wscript.shell")
     EnumFiles = Split(.Exec("cmd /c dir /b /s """ & path & """").StdOut.ReadAll, vbCrLf)
   End With
 End Function
（´・ω・`） 2022/02/23(水) 00:06

 同じことをFileSystemObjectでやってみると

 D:\test\　以下の *.xls* にマッチするファイルを列挙します
 サブフォルダも対象です

 Sub sample()
   Dim f
   For Each f In EnumFiles("D:\test", "*.xls*")
      Debug.Print f
   Next
 End Sub

 Function EnumFiles(path As Variant, Optional ByVal Filter As Variant) As Collection
   Dim ret As New Collection
   Dim f, subf
   If IsMissing(Filter) Then Filter = "*.*"
   Select Case TypeName(path)
      Case "String"
          With CreateObject("Scripting.FileSystemObject")
              If .FolderExists(path) Then
                 For Each f In EnumFiles(.GetFolder(path), Filter)
                     ret.Add f
                 Next
              ElseIf .FileExists(path) Then
                 ret.Add path
              End If
          End With
      Case "Folder"
          For Each f In path.SubFolders
              For Each subf In EnumFiles(f, Filter)
                 ret.Add subf
              Next
          Next
          For Each f In path.Files
             If f.Name Like Filter Then
                ret.Add f.path
             End If
          Next
      Case "File"
          If path.Name Like Filter Then
             ret.Add path.path
          End If
   End Select
   Set EnumFiles = ret
 End Function
 なんか無駄が多い気がしますが．．．
（´・ω・`） 2022/02/23(水) 07:24

 今回のケースに限定すれば（γ） 2022/02/22(火) 19:49　のようになると思いますが、
 FSOを使う、もう少し汎用的なものにするなら、以下のようなことになるかもしれません。
 めいぷるさんが紹介されたサイトの最後にあるものと同じです。
 モジュールベース変数に逃げたほうが楽かもしれません。

 Dim ret As Collection
 Dim fso As Object

 Sub sample()
     Const target As String = "D:\MyDocuments\202202"
     Dim f

     Set fso = CreateObject("Scripting.FileSystemObject")
     If Not fso.FolderExists(target) Then Exit Sub

     Set ret = New Collection
     Call EnumFiles(target, "*.xls*")
     For Each f In ret
         Debug.Print f
     Next
 End Sub

 Function EnumFiles(path As String, Optional ByVal Filter As String)
     Dim f, subf
     If IsMissing(Filter) Then Filter = "*.*"
     For Each f In fso.getfolder(path).Files
         If LCase(f.Name) Like Filter Then
             ret.Add f.path
         End If
     Next
     For Each subf In fso.getfolder(path).SubFolders
         Call EnumFiles(subf.path, Filter)
     Next
 End Function

 (追記）
 マナさん方式？の WshShellに関しては、下記が参考になるかもしれません。
https://atmarkit.itmedia.co.jp/ait/articles/0407/08/news101.html

 最近の方はコマンドラインを使うことも少ないのでしょうけど、
 Dir　のオプションについては、コマンドラインで、
 DIR /? (もしくは HELP DIR）とするとヘルプが見られます。
 /B /S などのオプションの内容が確認できます。

 なお、少し古いバージョンは
https://www.moug.net/tech/exvba/0060087.html
http://officetanaka.net/excel/vba/tips/tips27.htm
 などが参考になるかも。（似ているのは、作者が同じなので）

 引数の型を修正しました。

（γ） 2022/02/23(水) 09:17

 追記：拡張子だけでフォイルタを掛けるなら、こんなことになるのでしょうか。
 Call EnumFiles(target, "xls*")
 If IsMissing(Filter) Then Filter = "*"
 If LCase(fso.GetExtensionName(f.path)) Like Filter Then
（γ） 2022/02/23(水) 09:20

＞今回のケースに限定すれば（γ） 2022/02/22(火) 19:49　のようになると思いますが、
＞FSOを使う、もう少し汎用的なものにするなら、以下のようなことになるかもしれません。

誤解を招く文章でした。

今回のケースでは、「あ」フォルダの直下にExcelファイルはなく、
「あ」の下のサブフォルダ「ア」、「イ」「ウ」たちの配下にExcelファイルがある。
ただし、その下にさらにフォルダがあるということはない、
ということなので、2022/02/22(火) 19:49でよいという意味です。

ただ、今回の例を離れ、指定したフォルダの直下のファイルたちも含め、
さらにその配下のすべての深さのフォルダ内のファイルを相手にするという汎用的な目的であれば、以下のようになるでしょう、
という意味でした。
（γ） 2022/02/23(水) 13:25

多くの方がコメントいただきありがとうございます。
おかげさまで、ヒントになっている気もしますが、もうついていけません。

初歩的な質問にお答えいただける方がいらっしましたら、よろしくお願いします。

１
自分がマクロを実行したときに、データをコピーして抽出したいエクセル（サブフォルダーに入っているエクエル）を別の人が操作している場合、読み取り専用になりますが、それでもマクロは進むのでしょうか。
もしエラーなどなってしまうのであれば、?@最初にすべてのエクエルを一つのフォルダーに集める（他の人が操作しないエクセルを確保する）、?Aすべてのエクセルからデータをコピーするという２段階で操作した方がよいのでしょうか。

２
皆様とも、
Const target As String = "D:\MyDocuments\202202"などフォルダー名を最初から指定しているのかと思うのですが、ダイアログでその都度、指定することはできないのでしょうか。

３
エクセルを開く、データをコピーして操作しているエクセルに張り付ける、エクセルを閉じるということを繰り返ししたいのですが、どの部分にその記載をしたらよいのでしょうか。

（限界） 2022/02/23(水) 16:55

 (1)について
 御社のサーバー管理者に確認・相談してもらうのが良いと思います。
 ファイルサーバーの運用上の制約等がありうるからです。

 読み取りだけであれば動作自体はするかもしれません（試して見てください）。
 自分よりも早くにそのファイルを掴んで更新中の人がいれば、
 自分は少し古い情報をつかんでしまう可能性は当然残ります。

 (2)
 出発点のフォルダ名は検討のポイントになっていないので、決め打ちしただけのことです。
 その配下のフォルダ、ファイルを取得するのが主眼なので。
 どのようにでも随意に変更してください。

 (3)
 2022/02/22(火) 19:49で示したコードであれば、
 （省略）と書いた個所です。

 マナさん方式（Dirコマンド実行）のものであれば、
 該当のファイルたちのコレクションが得られますから、
 それを For each で順次取り出して、ファイル開く、処理、閉じる　と繰り返します。

 2022/02/23(水) 09:17のコードでも同じです。
 sample の最後のところで、
      For Each f In ret
          'Debug.Print f   これに代えて
          ここにパス名 f を使って、ファイル開き、処理、閉じるを実行します。
      Next
 とすればよいでしょう。

（γ） 2022/02/23(水) 18:51

2022/02/23(水) 09:17のコードは、
「あ」の直下にExcekファイルがもしあれば、それも対象にしますので注意してください。（再掲）

（γ） 2022/02/23(水) 18:55

    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
    Range("D1").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    End If
    Dim Folder_path
    Folder_path = ThisWorkbook.Worksheets("Sheet1").Range("D1").Value

　　Const target As String = Folder_path

では、エラーになってしまうかと思うのですが、ダイアログ表示させたものを、どうやって表現したらよいのでしょうか。
（限界） 2022/02/23(水) 19:57

Constではだめですよ。（少しも定数ではないので）
普通に、変数として宣言をしてください。
（γ） 2022/02/23(水) 20:19

ダイアログは成功しましたが、今後はファイルが開きません。
「For Each f In ret」という形で残したらよいですか。
Set ws = fso.OpenTextFile(target, ForReading)　の部分でエラー５になります。

Dim ret As Collection

 Dim fso As Object

Sub test6()

    Worksheets("Sheet1").Range("A1:J100").Clear
    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
    Range("D1").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    End If

    Dim target
    target = ThisWorkbook.Worksheets("Sheet1").Range("D1").Value

  Dim f
     Set fso = CreateObject("Scripting.FileSystemObject")
     If Not fso.FolderExists(target) Then Exit Sub
     Set ret = New Collection
     Call EnumFiles(CStr(target), "*.xlsm*")

                  For Each f In ret

     Set ws = fso.OpenTextFile(target, ForReading)

             ' (省略)
             ws.Close

     Next
 End Sub
 Function EnumFiles(path As String, Optional ByVal Filter As String)
     Dim f, subf
     If IsMissing(Filter) Then Filter = "*.*"
     For Each f In fso.getfolder(path).Files
         If LCase(f.Name) Like Filter Then
             ret.Add f.path
         End If
     Next
     For Each subf In fso.getfolder(path).SubFolders
         Call EnumFiles(subf.path, Filter)
     Next
 End Function

（限界） 2022/02/24(木) 10:35

 (1)
     For Each f In ret
         Stop
         'Set ws = fso.OpenTextFile(target, ForReading)
         ' (省略)
         'ws.Close
     Next
 と途中にStopを入れて、ローカルウインドウで
 ・retには何が入っているか
 ・f  には何が入っているか
 を確認してみてください。
 まず、何が出来ているかを改めて確認してもらいたいのです。

 Set ws = fso.OpenTextFile(target, ForReading)
 が突然出てきたのですが、これは何を意図したものですか？
 相手にするのはExcelのWorkbookじゃないんですか？

 (2)
 Option Explicit
 をモジュールの一行目に挿入するようにして下さい。
 そうすれば、今回のような未宣言の変数（ws )には警告が出て、 
 しかも場所を特定してくれます。

 http://officetanaka.net/excel/vba/beginner/06.htm
 を参照。

 VBEの 「ツール」 － 「オプション」 － 「編集」 で
 「変数の宣言を強制する」にチェックを入れてください。
 今後、モジュールを作成した時点で、Option Explicitが自動的に挿入されるので、
 手間が省けます。
 一度だけチェックを入れておきさえすれば、以後、気にする必要はありません。

（γ） 2022/02/24(木) 11:03

2022/02/22(火) 18:25で示されたブックに対する処理を
まずはひとつのブックで正常動作することを確認し、
そのうえで繰り返しのコードに反映するようにしたほうが確実かと思います。
（γ） 2022/02/24(木) 11:07

ありがとうございます。

（１）
　　　　（以上、略）

     Call EnumFiles(CStr(target), "*.xlsm*")

     For Each f In ret
         Stop
         'Set ws = fso.OpenTextFile(target, ForReading)
         ' (省略)
         'ws.Close
     Next

 End Sub
 Function EnumFiles(path As String, Optional ByVal Filter As String)
　　　　（以下、略）
としました。
すると、retにはすべてのサブフォルダー内のエクセル（xlms）が、variant/stringで表示されています。
fは、retの中の一つのエクセル（xlms）が、variant/stringで表示されています。

（γ） 2022/02/23(水) 18:51の (3)で、

ここにパス名 f を使って、ファイル開き、処理、閉じるを実行します。

      Next
 とすればよいでしょう

と教えていただいていますが、その記載方法が分からず、ネットで調べて、記載例をまねした次第です。
fsoになり、ファイルを開く、コピペする、閉じるの書き方もわからないんです。
おっしゃるとおり、相手にするのはExcelのWorkbookです。

（２）（３）
修正しました。
（限界） 2022/02/24(木) 11:31

FileSytemObjectにExcel固有の機能なんかありませんよ。
既に書かれているWorkbooks.Openメソッドで普通に開けばいいんですよ。
目指すパス名たちが取得できているのですから、FSOの出番はもうありません。
（γ） 2022/02/24(木) 11:39

確認されたように、fはファイルのパスという単なる文字列であって
FSOの特別のオブジェクトではありません。

｜ここにパス名 f を使って、ファイル開き、処理、閉じるを実行します。
と書きましたがFSOを使ってとは書いていませんよ。
Excelファイル(ブック)を操作するのは無論Excelアプリケーションの仕事でしょう。

FSOの記事サイトを紹介しましたが概要を読まれると良いでしょう。
（γ） 2022/02/24(木) 12:04

openファイルの記載方法についても、FSOの場合では違うのかと思ってしまいました。
申し訳ありません。

フォルダーを「f」
サブフォルダーを「subf」
にして、私が記載したのもを利用したらよいということですね。

すると、以下のようになりました。
一度もエクセルが開けれることなく終了してしまいます。
ステップインで確認しましたが、一度もファイルを開く部分にはいかずに終了してしまいました。
何が原因でしょうか。
よろしくお願いいします。

 Option Explicit

 Dim ret As Collection
 Dim fso As Object

Sub test6()

    Worksheets("Sheet1").Range("A1:J100").Clear
    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
    Range("D1").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    End If

    Dim target
    target = ThisWorkbook.Worksheets("Sheet1").Range("D1").Value

  Dim f
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(target) Then Exit Sub
    Set ret = New Collection
    Call EnumFiles(CStr(target), "*.xlsm*")

 Dim subf As String
    Do Until subf = ""

    Workbooks.Open Filename:=f
    Dim MergeWorkbook_MaxRow As Long
    Dim MaxRow As Long

    MergeWorkbook_MaxRow = f.Worksheets("表").Cells(Rows.Count, 1).End(xlUp).Row
    MaxRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

          If MaxRow = 2 Then
          f.Worksheets("表").Range("A1").CurrentRegion.Copy _
          ThisWorkbook.Sheets("Sheet1").Cells(MaxRow + 2, 1)

          Dim m As Long

          For m = 4 To MergeWorkbook_MaxRow + 1
          ThisWorkbook.Sheets("Sheet1").Range("J" & MaxRow + m) = f
          Next

          Else
          f.Worksheets("表").Range("A3").Select
          Range(Selection, Selection.End(xlToRight)).Select
          Range(Selection, Selection.End(xlDown)).Select
          Selection.Copy _
          ThisWorkbook.Sheets("Sheet1").Cells(MaxRow + 1, 1)

          Dim n As Long

            For n = 3 To MergeWorkbook_MaxRow
            ThisWorkbook.Sheets("Sheet1").Range("J" & MaxRow + n - 2) = f
            Next

        End If
        '結合するブックを閉じる
        Application.DisplayAlerts = False
            f.Close
        Application.DisplayAlerts = True
        subf = Dir()
'次のブックを探しに行く
        f = Dir()
    Loop
    Range("A1").Activate
End Sub
 Function EnumFiles(path As String, Optional ByVal Filter As String)
     Dim f, subf
     If IsMissing(Filter) Then Filter = "*.*"
     For Each f In fso.getfolder(path).Files
         If LCase(f.Name) Like Filter Then
             ret.Add f.path
         End If
     Next
     For Each subf In fso.getfolder(path).SubFolders
         Call EnumFiles(subf.path, Filter)
     Next
 End Function

（限界） 2022/02/24(木) 13:55

 For Each f In ret
      Stop
 ここで止めて、retやfの内容が確認できたのに、
 どうして  For Each f In ret　を消してしまうのですか？
 折角確認できたのに。
（変数名が不適切だったかな。流れで来てしまったけれど）

 また、Dir()が復活しているのは何を目的としているのですか？
 Excelのファイルのパスはもう確定できたじゃないですか。

     For Each f In ret
        Set wb = Workbooks.Open(f)
            ここにwbを使った処理を書きます
        wb.Close False
     Next
 という構造になるんですが。 
（γ） 2022/02/24(木) 14:07

 ああ、そうか
 For Each f In retの意味が不明確なんですかね。

 retというのは、フルパスたちを集めた、Collectionというオブジェクトです。

 For Each f In retは、
 ・その要素を一つずつ fに取り出して、
 ・すべての要素について繰り返しを行うための命令です。

 ローカルウインドウで確認されましたよね。
 それを一つずつ取り出してくれるので、それだけをもとに処理すればいいいんです。

  Do Until subf = ""
  Loop
　といった繰り返し処理は使いません。不要です。

（γ） 2022/02/24(木) 14:14

ありがとうございます。
Do Until subf = ""の後に常にLoopまで飛んでいたのでなぜかと思ったのですが、そういうことですね。
以下のように修正したのですが、Workbooks.Open Filename:=fの部分で、「エラー1004　Openメソッドは失敗しました。Workbooksオブジェクト」となってしまいました。

 Option Explicit

 Dim ret As Collection
 Dim fso As Object

Sub test6()

    Worksheets("Sheet1").Range("A1:J100").Clear
    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
    Range("D1").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    End If

    Dim target
    target = ThisWorkbook.Worksheets("Sheet1").Range("D1").Value

  Dim f
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(target) Then Exit Sub
    Set ret = New Collection
    Call EnumFiles(CStr(target), "*.xlsm*")

         For Each f In ret

 Dim subf As String
    Do Until subf = ""

    Workbooks.Open Filename:=f
    Dim MergeWorkbook_MaxRow As Long
    Dim MaxRow As Long

    MergeWorkbook_MaxRow = f.Worksheets("表").Cells(Rows.Count, 1).End(xlUp).Row
    MaxRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

          If MaxRow = 2 Then
          f.Worksheets("表").Range("A1").CurrentRegion.Copy _
          ThisWorkbook.Sheets("Sheet1").Cells(MaxRow + 2, 1)

          Dim m As Long

          For m = 4 To MergeWorkbook_MaxRow + 1
          ThisWorkbook.Sheets("Sheet1").Range("J" & MaxRow + m) = f
          Next

          Else
          f.Worksheets("表").Range("A3").Select
          Range(Selection, Selection.End(xlToRight)).Select
          Range(Selection, Selection.End(xlDown)).Select
          Selection.Copy _
          ThisWorkbook.Sheets("Sheet1").Cells(MaxRow + 1, 1)

          Dim n As Long

            For n = 3 To MergeWorkbook_MaxRow
            ThisWorkbook.Sheets("Sheet1").Range("J" & MaxRow + n - 2) = f
            Next

        End If
        '結合するブックを閉じる
        Application.DisplayAlerts = False
            f.Close
        Application.DisplayAlerts = True

'次のブックを探しに行く

    Loop

    Next

    Range("A1").Activate
End Sub
 Function EnumFiles(path As String, Optional ByVal Filter As String)
     Dim f, subf
     If IsMissing(Filter) Then Filter = "*.*"
     For Each f In fso.getfolder(path).Files
         If LCase(f.Name) Like Filter Then
             ret.Add f.path
         End If
     Next
     For Each subf In fso.getfolder(path).SubFolders
         Call EnumFiles(subf.path, Filter)
     Next
 End Function

（限界） 2022/02/24(木) 14:37

不要と申し上げたDo Loopが残ってますが？
ステップ実行をして
実際にファイルを開きに行っているか、
エラー時のfの値が何か調べてください。

もっと言えば
キチンとインデントをつけて
ご自分なりのコメントを書き入れたらどうですか。
ご自分の理解も少しすると忘れがちですから。

（γ） 2022/02/24(木) 15:09

失礼しました。
操作しているエクエルでは「Do Until subf = ""」「Loop」を削除していましたが、それらを削除する前のコードを張り付けてしまいました。

fのには、●●●●.xlsmとなっているので、f自体は正しいファイルまでたどり着けているが、Workbooks.Open Filename:=fの記載方法が良くないのかと思ったのですが、そうではないのでしょうか。
（限界） 2022/02/24(木) 16:40

特に問題とは思いませんが、なにせ提示されたものが、実際に動かしたものと同一である保証がないので、
何とも言えません。
サンプルのブックを開く動作をマクロ記録して、それと比較してみてはいかがですか？

（γ） 2022/02/24(木) 17:30

 エラーが起きたのは
     Workbooks.Open Filename:=f
 ではないでしょう？

 以下で、エラーになりますよ。
     MergeWorkbook_MaxRow = f.Worksheets("表").Cells(Rows.Count, 1).End(xlUp).Row
 などと f を使っていますが、
 f は単なる文字列なので、Workbookオブジェクトではありません。
 f.Worksheets("表")は全く意味を成しません。

 Dim wb As Workbook と変数を定義しておいて
 Set wb = Workbooks.Open(Filename:=f)
 とし、以下、
     MergeWorkbook_MaxRow = wb.Worksheets("表").Cells(Rows.Count, 1).End(xlUp).Row
 といったようにするのではないですか？

 大丈夫ですか？

（γ） 2022/02/24(木) 18:29

ご心配かけてしまい申し訳ありません。
まだまだ苦労しています。

とりあえず、データを持っているエクセルの「表」シート全体を、現在操作しているsheet4に丸ごとコピーして、sheet4のうち必要な情報を取捨選択すること変更しました。
初めに、sheet4にまるごとコピーすることを試しているのですが、やはり「Set wb = Workbooks.Open(Filename:=f)」が黄色くなり、「エラー1004　Openメソッドは失敗しました。Workbooksオブジェクト」と表示されます。

    （以上、略）
　　Call EnumFiles(CStr(target), "*.xlsm*")

    For Each f In ret

    Dim wb As Workbook
    Set wb = Workbooks.Open(Filename:=f)

    wb.Worksheets("表").Copy After:=ThisWorkbook.Sheets("Sheet4").Range("A1")

    ThisWorkbook.Sheets("Sheet4").Cells.Clear

    Next

End Sub
（限界） 2022/02/24(木) 19:04

全体を省略せずにアップしてもらえますか？
私としては最後のトライにしたいと思っていますので。

（γ） 2022/02/24(木) 20:11

直接の原因ではありませんが、
ついでにコメントしておきますと、
wb.Worksheets("表").Copy After:=ThisWorkbook.Sheets("Sheet4").Range("A1")
は必ずエラーになります。
シートを、特定のセルのあとに、　という構文はありません。
（γ） 2022/02/24(木) 21:23

 エラーが発生したというのは、以下のようなことではないですか？

 ブックを開いたままの状態で、
 もう一度実行したのではないですか？
 その場合、開いたブックの内部ファイル（~$で始まる差分管理のためのファイル）が
 対象にひっかかり、それを開こうとしてエラーななったのでは？
 エラーメッセージを念入りに読めば、理由はわかったはずです。
 拡張子は.xls*であっても、ユーザーが普通に開くような通常のブックではないので、
 エラーになりますね。

 すでに書いたように、
 　・ブックは開いて、
 　・作業したら、
 　・その都度閉じる
 とすれば、そのようなことは起きません。

 いずれにしても、ファイルのパスを取得してしまえば、
 あとは、コピーペイスト中心の普通のマクロですよね。
 特に難しいところはないはずです。頑張ってください。
（γ） 2022/02/25(金) 17:20

コメント返信：

[ 一覧(最新更新順) ]

[[20220222115644]] 『複数のフォルダーに入っているエクセルからデータ』（限界） ページの最後に飛ぶ

[[20220222115644]]　『複数のフォルダーに入っているエクセルからデータ』（限界）　ページの最後に飛ぶ