スキルアップ・問題解決なら、モーグにおまかせ！

いつもお世話になっております。
複数のエクセルシートに記載されている内容をとりまとめるＶＢＡを記述したいと
考えています。ネットなどの情報から見様見真似で下記のとおりコートを作成したところ、1つのエクセル（test001）の情報についてはコピーすることができました。（下記コードです。）
しかしながら、このような作業を自動で６０回程度動かすためのコードの記述の仕方が分かりません。
みなさま大変お忙しいところ恐縮ですが、ご教示いただけますと幸いです。
何卒よろしくお願い申し上げます。
補足）６０個程度のエクセルには、全てシート１の同じ場所に情報が記載されています。
 
Sub TEST1()
 
  Dim A
' ファイルパスを指定
  A = ThisWorkbook.Path & "\TEST001\test01.xlsx"
 
  Workbooks.Open A 'ブックを開く
 
  ActiveWorkbook.Sheets(1).Range("E4:E44").Copy ThisWorkbook.Sheets("sheet1").Range("F2")
  ThisWorkbook.Sheets("sheet1").Range("F2").ColumnWidth = 55
   
End Sub
 

＞全てシート１の同じ場所
 
それって、「E4:E44」の決め打ちでいい、と言うことですか？
 
念の為にお聞きしますが、E44セルには必ずデータが入っているんですか？

まず、どの様にしたいのかを説明してください。
何処で詰まっているのか？
 
例えば、
複数存在するブック・・・・ブック名を６０個も指定しなくてもできる方法が知りたい
とか・・・

こちらの質問掲示板のなかに、即効テクニックという記事群があります。
[複数ブックのシートを1つのブックにコピーする]
https://www.moug.net/tech/exvba/0060003.html
が参考になるのでは？
 
一つのフォルダ内のブックを順次開いて、処理して、閉じて、という作業のひな型になるでしょう。

半平太　様
 
> それって、「E4:E44」の決め打ちでいい、と言うことですか？
> 念の為にお聞きしますが、E44セルには必ずデータが入っているんですか？
 
E44にはデータが入っていない可能性もあります。
イメージとしてはアンケート調査への回答項目がE4からE44まであるような感じです。
よろしくお願いいたします。
 
WinArrow　様
 
> まず、どの様にしたいのかを説明してください。
> 何処で詰まっているのか？
 
やりたいことは、WinArrow様からもご指摘いただいているように、
60個のファイルを一つ一つ指定しなくても取り込めるようにしたいです。
よろしくお願いいたします。

【補足説明】
　やりたいことは、60個あるエクセルファイルのシートをコピーして1つのエクセルにまとめるということではなく、60個あるエクセルファイルのセルのデータを１つのエクセルシートにまとめたいということです。説明が拙く大変恐れ入りますが、よろしくお願いいたします。

よく読んでいただきたいですね。
＞一つのフォルダ内のブックを順次開いて、処理して、閉じて、という作業のひな型になるでしょう。
Dir関数を使って、ブックに順次作業を行うひな型になると申し上げています。
そのまま使えるコードを示したつもりはありません。
あえて「処理」と書いているでしょう？
 
・ワークシートをコピーするのではなく、
・既に出来上がっている、セル範囲のコピーに適用してください。
ふたつの手法を組み合わせるのです。

60個 のブック と言いますが、その 60個を どう指定するのですか？
・特定のシートのA列にブックパスを指定する
・特定のフォルダにあるブック
　　：
　　etc
 
 
最初のブックのデータを、シート Sheet1 の F2 に 貼り付けたいのは判りますが
じゃぁ、次の ブックのデータは どこに 張り付けたいのですか？ F2 では無いですよね？
・F2 から 40個データなので、次は F42 から その次は F82 から ・・
・F2 から 横方向　次は、G2 から、その次は H2 から ・・
 
等、条件がいろいろ不足しているのですよ。
 
 
と言ってもはじまらないので
 
・特定フォルダにあるブック(xlsx)
・貼り付け先 は、当該ブックの F2 から G2、H2・・と横方向に
・1行目 には、ブック名称を入れる
を条件に
 
コードを提示します。希望と違う部分は適宜修正ください。
 

Sub Sample()
  '※ 要参照設定 Microsoft Scripting Runtime

  Dim FSO As Scripting.FileSystemObject
  Dim Fld As Scripting.Folder
  Dim Fil As Scripting.File

  Dim FldPath As String
  Dim FileName As String

  Dim wbk As Workbook

  Dim c As Long

  FldPath = "フォルダフルパス指定"

  Set FSO = CreateObject("Scripting.FileSystemObject")

  If FSO.FolderExists(FldPath) = False Then
    MsgBox "フォルダなし"
    GoTo Exit_Sample
  End If

  Set Fld = FSO.GetFolder(FldPath)

  With ThisWorkbook.Worksheets("Sheet1")
    c = .Cells(2, .Columns.Count).End(xlToLeft).Column
  End With
  If c <= 6 Then c = 6

  For Each Fil In Fld.Files
    If FSO.GetExtensionName(Fil) = "xlsx" Then
      Stop
      Set wbk = Application.Workbooks.Open(Fil.Path)
      wbk.Worksheets(1).Range("E4:E44").Copy ThisWorkbook.Worksheets("Sheet1").Cells(2, c)
      ThisWorkbook.Worksheets("Sheet1").Cells(1, c).Value = FSO.GetBaseName(Fil)
      wbk.Close
      c = c + 1
    End If
  Next

Exit_Sample:
  Set wbk = Nothing
  Set Fil = Nothing
  Set Fld = Nothing
  Set FSO = Nothing
End Sub

[quote="simple"]よく読んでいただきたいですね。
＞一つのフォルダ内のブックを順次開いて、処理して、閉じて、という作業のひな型になるでしょう。
Dir関数を使って、ブックに順次作業を行うひな型になると申し上げています。
そのまま使えるコードを示したつもりはありません。
あえて「処理」と書いているでしょう？
 
simple　様
 
申し訳ございません。私の読解力不足でした。
皆様のご指摘を参考にしながら、遣っていきたいと思います。
引き続きよろしくお願いいたします。

質問のメインは、こっちなんですけどねぇ・・
　　　　　　　　↓
＞それって、「E4:E44」の決め打ちでいい、と言うことですか？
 
以下、決め打ちでいいものとします。
 

Sub TEST1()
    Dim A, FileX, RwtoRite As Long
    
    ' ファイルパスを指定
    A = ThisWorkbook.Path & "\TEST001\"

    FileX = Dir(A & "*.xls*")
    
    Application.ScreenUpdating = False
    
    Do While FileX <> ""
        RwtoRite = RwtoRite + 41
        
        With Workbooks.Open(A & FileX, , True).Sheets(1)         '読み取り専用でブックを開く
            .Range("E4:E44").Copy ThisWorkbook.Sheets("Sheet1").Cells(RwtoRite - 39, "F")
            .Parent.Close False
        End With
        
        FileX = Dir()
    Loop
    
    ThisWorkbook.Sheets("Sheet1").Range("F2").ColumnWidth = 55
    Application.ScreenUpdating = True
End Sub

Suzu　様
 
> 最初のブックのデータを、シート Sheet1 の F2 に 貼り付けたいのは判りますが
> じゃぁ、次の ブックのデータは どこに 張り付けたいのですか？ F2 では無いですよね？
> ・F2 から 40個データなので、次は F42 から その次は F82 から ・・
> ・F2 から 横方向　次は、G2 から、その次は H2 から ・・
  
> 等、条件がいろいろ不足しているのですよ。
 
大変恐れ入ります。
他の皆様にもご指摘いただいておりますとおり、私が何を遣りたいかということを、具体的に
説明が出来ておりませんでした。お手数をおかけして大変申し訳ございません。
 
 
条件についてですが、
 
>・特定フォルダにあるブック(xlsx)
 
はい。そのとおりです。
 
・貼り付け先 は、当該ブックの F2 から G2、H2・・と横方向に
 
はい。そのとおりです。F2から横方向です。
 
>・1行目 には、ブック名称を入れる
 
これについては、必要ございませんのでコードの修正について
考えます。
 
先ずは教えて頂いた内容で試してみたいと思います。
今後ともよろしくお願いいたします。

Suzu　様
 
お世話になっております。
早速、ご教示いただいたコードを試してみました。
 
遣りたいことは実現できたのですが、
 
> If FSO.GetExtensionName(Fil) = "xlsx" Then
> Stop
 
　STOPのところで、一度、ストップしその後、F8で進めていけばその後は最後までデータの取り込みは完了します。
　大変不勉強で恐れ入りますが、Stopを入れた意図というのはどのようなことからでしょか。
　削除した場合は、何かしら不具合が発生する恐れがありますでしょうか。

引用:
遣りたいことは実現できた

引用:
　STOPのところで、一度、ストップしその後、F8で進めていけばその後は最後までデータの取り込みは完了します。
　大変不勉強で恐れ入りますが、Stopを入れた意図というのはどのようなことからでしょか。
　削除した場合は、何かしら不具合が発生する恐れがありますでしょうか。

Suzu　様
 
お世話になっております。
 
参照設定をしている場合には、下記の記述は書かなくてもよいという
ことをネットで調べたのですが、敢えて記載しているのは、参照設定を
していないパソコンにおいてもエラーとならないようにという趣旨から
でしょうか。
 
> Set FSO = CreateObject("Scripting.FileSystemObject")

Suzu　様
 
お世話になっております。
最後にもう１点ご教示頂きたいです。
 
60個のファイル名には、01_テスト、02_テスト、03_テスト、・・・60_テストのように名前の頭に番号が振られています。データの取り込み順番をこの番号順に実施することは可能でしょうか。

横から失礼。
Filesからの取り出し順序をコントロールすることはできないはずなので、
ファイル名も出力する当初の提案を採用して、
いったん処理をした後で、ファイル名でソートすればよいのでは？
（列単位のソートができますから）
そういったこともあって、Suzuさんは提案されたはずです。
  
また、折角、Dir関数を使ったコードを提供された回答者さんがいらっしゃるわけだから、
無視するのではなく、きちんと礼をつくしたほうがいいですよ。
貴重な時間を掛けて下さっているわけです。そう思いませんか？
  
（ちなみに、Dir関数も学習しておくと使える機会もありますよ。
たとえば、ファイルの存在確認が簡単にできるとか。
この機会にそれも少し学習されたらいかがですか？）

半平太　様
 
おはようございます。
ご教示頂き大変ありがとうございます。。
お返事が遅くなり申し訳ありません。
 
ただいま、動作確認を行っているところです。
その後報告も改めてさせて頂きたいと思います。　
 
引き続きよろしくお願いいたします。　　

simple　様
 
おはようございます。
お世話になっております。
 
> Filesからの取り出し順序をコントロールすることはできないはずなので、
> ファイル名も出力する当初の提案を採用して、
>いったん処理をした後で、ファイル名でソートすればよいのでは？
>（列単位のソートができますから）
> そういったこともあって、Suzuさんは提案されたはずです。
 
Suzu様の提案はそのような意図もあったのですね。
検討してみます！ありがとうございます。
 
> また、折角、Dir関数を使ったコードを提供された回答者さんがいらっしゃるわけだから、
> 無視するのではなく、きちんと礼をつくしたほうがいいですよ。
>貴重な時間を掛けて下さっているわけです。そう思いませんか？
  
おっしゃる通りです。
最初の回答への対応に追われ失念しておりました。
以後はこのようなことがないよう気を配ってまいりたいと思います。
 
 
> （ちなみに、Dir関数も学習しておくと使える機会もありますよ。
> たとえば、ファイルの存在確認が簡単にできるとか。
> この機会にそれも少し学習されたらいかがですか？）
 
そうですね。せっかくの機会ですので、半平太様のコードを通して理解を
深めていけたらと考えております。ありがとうございます。

私の記憶違いで、FSOのFolderオブジェクトのFilesコレクションの順序は
文字列の昇順かもしれません。
並べ替えしなくてもよいかもしれません。
ファイル名を出力して確認してみて下さい。
いずれにしても、データの出所はシートに書き込んだほうがよいと思います。
（不要であれば、用済み後に消すのは簡単です。）

半平太　様
 
ご教示いただきましたコードは、縦列にデータを追加するものとなっていましたので
私の方でSuzu様からご教示いただきましたコードなどを参考に下記のとおり修正しま
した。その結果、遣りたいことはほぼできたのですが、最初に取り込んだファイル名が
記載されず、２つ目のファイル名からは記載される状況となっています。
おそらく、下記コードの記述場所又は記述内容が少し違っているのかなとも思うのですが。。。
 
>ThisWorkbook.Worksheets("Sheet1").Cells(1, c).Value = FileX
 
 
 
Sub TEST1()
     
    Dim A As String
    Dim FileX As String
     
    ' ファイルパスを指定
    A = ThisWorkbook.Path & "\TEST001\"
 
    FileX = Dir(A & "*.xls*")
     
    Application.ScreenUpdating = False
     
 
    With ThisWorkbook.Worksheets("Sheet1")
        c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    End With
   
    If c <= 5 Then c = 5
 
        Do While FileX <> ""
            With Workbooks.Open(A & FileX, , True).Sheets(1) '読み取り専用でブックを開く
            .Range("E4:E44").Copy ThisWorkbook.Worksheets("Sheet1").Cells(2, c)
            .Parent.Close False
        End With
           c = c + 1
           FileX = Dir()
           ThisWorkbook.Worksheets("Sheet1").Cells(1, c).ColumnWidth = 45
           ThisWorkbook.Worksheets("Sheet1").Cells(1, c).Value = FileX
    　 Loop
 
    Application.ScreenUpdating = True
     
End Sub
 

simple　様
 
> 私の記憶違いで、FSOのFolderオブジェクトのFilesコレクションの順序は
> 文字列の昇順かもしれません。
> 並べ替えしなくてもよいかもしれません。
 
おっしゃるとおり、昇順で出力されることを確認いたしました。
大変ありがとうございました。

ファイルオブジェクトの順番 については、昇順の保証はないです。
 
 
https://teratail.com/questions/240335
VBAでFilesコレクションからオブジェクトを逆順に取得する方法
 

引用:
NTFSはソートされて取得できますが
FAT32の場合ファイルの作成された順に取得されます。

お世話になっております。
下記のとおりコードを修正したら遣りたいことができました。
皆様には色々とご教示いただき大変感謝申し上げます。
 
 
Sub TEST1()
     
    Dim A As String
    Dim FileX As String
     
    ' ファイルパスを指定
    A = ThisWorkbook.Path & "\TEST001\"
 
    FileX = Dir(A & "*.xls*")
     
    Application.ScreenUpdating = False
     
 
    With ThisWorkbook.Worksheets("Sheet1")
        c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    End With
   
    If c <= 5 Then c = 5
 
        Do While FileX <> ""
            With Workbooks.Open(A & FileX, , True).Sheets(1) '読み取り専用でブックを開く
            .Range("E4:E44").Copy ThisWorkbook.Worksheets("Sheet1").Cells(2, c)
            .Parent.Close False
        End With
> ThisWorkbook.Worksheets("Sheet1").Cells(1, c).ColumnWidth = 45
> ThisWorkbook.Worksheets("Sheet1").Cells(1, c).Value = FileX
            
           c = c + 1
           FileX = Dir()
 
        Loop
     
    Application.ScreenUpdating = True
         
End Sub
 

出来た・・・・
 
水を差すようだけど

引用:

    With ThisWorkbook.Worksheets("Sheet1")
        c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    End With
    
    If c <= 5 Then c = 5

お世話になっております。
実際に動かしてみて、気になる動作がありましたので、ご教示頂きたいです。
お忙しいところ恐れ入りますが宜しくお願い致します。
 
 
【追加で確認したいこと】
 
【不具合】
　Ｅ２が空白（取り込みファイル０個）のとき、７個のファイルを取り込んだ後に、追加で７個のファイルの取り込みをした場合、一部のデータが上書きされてしまいます。具体的には、Ｈ２までは、最初の取り込んだファイルのデータで、Ｉ２からは２回目に取り込んだデータが始まっています。
 
【遣りたいこと】
�@先に述べた不具合については、２回目の取り込みデータは、Ｌ２から始まるようにはできないか。３回目以降の取り込みについても最終列の次から始まるようにできないか。
 
�A既に取り込んでいるデータがある場合には、そのファイルのデータは取り込まないようにできないか。
 
 
何卒宜しくお願い致します。
 

WinArrow　様
 
お世話になっております。
大変恐れ入りますが、下記についてどのように書けばよいのかご教示頂きたいです。
宜しくお願い致します。
 
>　Max関数を使うと
> If c <= 5 Then c = 5
>　は不要になります。

引用:

【不具合】
　Ｅ２が空白（取り込みファイル０個）のとき、７個のファイルを取り込んだ後に、追加で７個のファイルの取り込みをした場合、一部のデータが上書きされてしまいます。具体的には、Ｈ２までは、最初の取り込んだファイルのデータで、Ｉ２からは２回目に取り込んだデータが始まっています。

若しかしたら
１回目の７番目のファイルの
セルＥ４が空白とかありませんか？

WinArrow　様
 
いつもお世話になっております。
お世話になっております。
よろしくお願いいたします。
 
> 若しかしたら
> １回目の７番目のファイルの
> セルＥ４が空白とかありませんか？
 
はい。ございます。
幾つかのファイルでＥ４が空白になっていることがわかりましたので、
それを全て埋めたうえで取り込んだところ、今度は、
 
> ２回目取込んだ時、「Ｋ]列が２回目のデータで、上書きされている
> というのでしたら、理解できます。・・・・コードがそのようになっていますから・・・
 
という問題が発生しました。
 
大変恐れ入りますが、２回目以降の取り込み時、前回に取り込んだデータが上書きで
消されることがないようにしたいです。今回の例で言えば、Ｉ列から２回目のデータを
取り込むように処理していきたいです。ご教示頂きたいです。よろしくお願いいたします。

お世話になっております。
コードを下記のとおり修正したところ、上手く作動しているように思えるのですが、
対応としては合ってますでしょうか。ご教示頂けたら幸いです。宜しくお願い致します。
 
> With ThisWorkbook.Worksheets("Sheet1")
> c = .Cells(2, .Columns.Count).End(xlToLeft).Column + 1
> End With
  

マイルストン さんの引用:
お世話になっております。
コードを下記のとおり修正したところ、上手く作動しているように思えるのですが、
対応としては合ってますでしょうか。ご教示頂けたら幸いです。宜しくお願い致します。
 
> With ThisWorkbook.Worksheets("Sheet1")
> c = .Cells(2, .Columns.Count).End(xlToLeft).Column + 1
> End With
  

 With ThisWorkbook.Worksheets("Sheet1")
    c = WorksheetFunction.Max(.Cells(2, .Columns.Count).End(xlToLeft).Column + 1, 5)
  End With

感想だけですみません。
 
アンケート的なデータの読み込みということであれば、
・読み込み先の領域（２行目以下）は初期化し
・最初の読み込み先も固定的に指定し、
・全体を一括して読み込むことを推奨します。
複数に分けてとか、ものごとを複雑にする必要もないと思いますよ。
やり直す場合も、改めて初期化してから全体を読み込むようにしてください。

WinArrow　様
 
お世話になっております。
 
> 他人（回答者の提供を含む）からのコードを単純にコピペするのではなく、
> コードの意味をキチンと理解することが大切です。
 
はい。今後は丸写しで終了するのではなく、その意味についてもしっかりと理解
するようにし、上達に努めます。
 
> ThisWorkbook.Worksheets("Sheet1").Cells(1, c).Value = FileX
>　は、1行目には、必ずデータが入るので、1行目を利用する方法もありますね・・・
 
なんとなく、おっしゃりたいことは分かりますので、考えてみます。
 
> Max関数を利用について
 
Max関数を利用した場合は下記のコードは必要なくなるのでしょうか？
> If c <= 5 Then c = 5
 
Simple　様
 
お世話になっております。
 
> アンケート的なデータの読み込みということであれば、
> 複数に分けてとか、ものごとを複雑にする必要もないと思いますよ。
> やり直す場合も、改めて初期化してから全体を読み込むようにしてください。
 
そうですね。その方が分かり易いですし効率的な気がします！
色々とご教示いただき本当にありがとうございました。

質問が長くなってしまい大変申し訳ございません。
 
最後にもう１点ご教示いただきたいです。
 
取り込んだ件数をメッセージボックスで表示させたく、下記のとおりコードを修正し
実行したところ件数が表示されました。記載したコードの記述方法について、こうした方が
良いと思う記述方法がありましたら、是非ご教示いただきたいです。よろしくお願いいたし
ます。
 
> Dim A As String
> Dim FileX As String
     Dim FileInt As Long
 
（省略）
 
> ThisWorkbook.Worksheets("Sheet1").Cells(1, c).ColumnWidth = 45
> ThisWorkbook.Worksheets("Sheet1").Cells(1, c).Value = FileX
> c = c + 1
> FileX = Dir()
            FileInt = FileInt + 1
> Loop
 
 　 MsgBox "取り込んだファイル数は" & FileInt & "件です"
 
（省略）

引用:

記載したコードの記述方法について、こうした方が
良いと思う記述方法がありましたら、是非ご教示いただきたいです。よろしくお願いいたし
ます。

WinArrow　様
 
 
 
[quote="WinArrow"]

引用:

メッセージ表示の目的にあっていれば、よいのでは？
目的が赤らない他人に訊くことではありません。
あなたが考えることです。