複数のブックをひとつのブック（複数のシートにまとめる）場合にシートとの順番について

あるフォルダーに複数のブック（1シートのみ）が入っています。フォルダー内のブック名（
横浜、大阪、東京、福岡、名古屋　※作成日作成時間が古い順に格納されています）
これをひとつのブックにまとめるマクロを探しました。下記記述で一つにまとまったのですが各シートが元のフォルダに入っているブック順になっていません。一つにまとめた後にまたシートの順番を作成時間の古い順に並べ替えているので、初めから古い順番からシートを並べるようにできないでしょうか。

　
Sub TEST2()
Dim A
'フォルダ内のブック名を取得
A = Dir(ThisWorkbook.Path & "\TEST\*")
Do While A <> ""
'ブックを開く
Workbooks.Open ThisWorkbook.Path & "\TEST\" & A
With ActiveWorkbook
'シートをコピーして取得
.Worksheets("Sheet1").Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
'シート名をブック名に変更
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = .Name
.Close False 'ブックを閉じる
End With
A = Dir() '次のブック名を取得
Loop

End Sub

No.5 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/12/29 17:57

以下のマクロを標準モジュールに登録してください。

Option Explicit

Type D_TYPE
name As String
udate As Date
End Type

Public Sub 日付順に格納()
Dim trgfiles() As D_TYPE
Dim trgfile As D_TYPE
Dim fcount As Long: fcount = 0
Dim i As Long
Dim FSO As Object
Dim folder As Object
Dim files As Object
Dim file As Object
Dim wb As Workbook
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder(ThisWorkbook.Path & "\TEST")
Set files = folder.files
For Each file In files
ReDim Preserve trgfiles(fcount)
trgfiles(fcount).name = file.name
trgfiles(fcount).udate = file.datelastmodified
fcount = fcount + 1
Next
Call file_sort(fcount, trgfiles)
For i = 0 To fcount - 1
'Debug.Print trgfiles(i).name, trgfiles(i).udate
Set wb = Workbooks.Open(folder.Path & "\" & trgfiles(i).name)
'シートをコピーして取得
wb.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
'シート名をブック名に変更
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).name = trgfiles(i).name
wb.Close False 'ブックを閉じる
Next
End Sub

Private Sub file_sort(ByVal fcount As Long, trgfiles() As D_TYPE)
If fcount < 2 Then Exit Sub
Dim i As Long
Dim j As Long
Dim temp As D_TYPE
For i = 0 To fcount - 2
For j = i + 1 To fcount - 1
If trgfiles(i).udate > trgfiles(j).udate Then
temp = trgfiles(i)
trgfiles(i) = trgfiles(j)
trgfiles(j) = temp
End If
Next
Next
End Sub

この回答へのお礼

ありがとうございます。思った通りの順番に並べることができました。色々試してみるとシート名の頭に数字が振ってあれば数字順に並ぶようでしたがその他はどんな法則で並んでいるかがわかりませんでした。簡単に考えていたのですがこんなに長くて難しい記述が必要なのですね。
大変お手数をおかけいたしました。

お礼日時：2022/12/30 06:44

No.4 回答者： Qchan1962 回答日時： 2022/12/29 12:35

#2　です

検証せずにすみません
Dim v As Variant　を　Dim v As Date　にしてみてください

No.3 回答者： banzaiA 回答日時： 2022/12/29 00:32

VSTACK関数は使えない環境ですか？

この回答へのお礼

お世話になります。
関数検索したら出てきましたので使えるのではないかと思いますが使い方がわかってないため、色々調べてみます。

お礼日時：2022/12/29 04:56

No.2 回答者： Qchan1962 回答日時： 2022/12/29 00:02

こんばんは　

FileSystemObjectでフォルダ内のファイルの情報を配列に取得します
（シートに書き出す事が出来るのなら書き出した方が簡単で書き出した範囲をループで取得して開く）
シートに書き出さない場合
作成した配列を要素の作成日作成時間を基にソート（関連要素同様）して
その配列のファイルパス要素を順にOpen（Sub TEST2）します

余談
Sub TEST2について"Sheet1"で良いのかも知れませんが、csvファイルなどの場合ファイル名がシート名になるのでインデックスで書く方が無難です
.Worksheets(1).Copy

一例です
Option Explicit
Dim arrFpath()
Sub example()　'実行プロシージャ
Dim fPath As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
fPath = ThisWorkbook.Path & "\TEST"
Dim fl As Object
Set fl = FSO.GetFolder(fPath)
Dim f As Object
Dim n As Long
For Each f In fl.Files
If LCase(f.Name) Like "*.xls*" Then
ReDim Preserve arrFpath(1, n)
arrFpath(0, n) = fPath & "\" & Dir(f) 'フルパス
arrFpath(1, n) = f.DateCreated ' 作成日時
'f.DateLastModified ' 更新日時
n = n + 1
End If
Next
Set FSO = Nothing
Call quick_sort(arrFpath, LBound(arrFpath, 2), UBound(arrFpath, 2))
'Range("A1").Resize(UBound(arrFpath, 2) + 1, UBound(arrFpath, 1) + 1).Value _
'= WorksheetFunction.Transpose(arrFpath)
Call TEST01(arrFpath)
End Sub
Sub TEST01(arrPath)
Dim i As Long
Application.ScreenUpdating = False
For i = 0 To UBound(arrPath, 2)
'ブックを開く
Workbooks.Open arrPath(0, i)
With ActiveWorkbook
'シートをコピーして取得
.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
'シート名をブック名に変更
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = .Name
.Close False 'ブックを閉じる
End With
Next
Application.ScreenUpdating = True
End Sub
Sub quick_sort(arrFpath, Lb, Ub)
Dim i As Long, j As Long
Dim v As Variant
v = arrFpath(1, Int((Lb + Ub) / 2))
i = Lb: j = Ub
Dim buf As String, tmp As String
Do
Do While arrFpath(1, i) < v
i = i + 1
Loop
Do While v < arrFpath(1, j)
j = j - 1
Loop
If i >= j Then Exit Do
buf = arrFpath(1, i)
tmp = arrFpath(0, i)
arrFpath(1, i) = arrFpath(1, j)
arrFpath(0, i) = arrFpath(0, j)
arrFpath(1, j) = buf
arrFpath(0, j) = tmp
i = i + 1
j = j - 1
Loop
If Lb < i - 1 Then Call quick_sort(arrFpath, Lb, i - 1)
If j + 1 < Ub Then Call quick_sort(arrFpath, j + 1, Ub)
End Sub

この回答へのお礼

お世話になっております。色々ありがとうございます。貼り付けて何度か実施してみましたがやはり作成日作成時間順に並びません。当方のやり方の問題があると思いますので自身で色々調べてみます。

お礼日時：2022/12/29 05:11

No.1 回答者： mygoonickname 回答日時： 2022/12/28 21:37

こんばんは。

検索した記事ですが、下記のコードが参考になるかと思います。

●フォルダ内のファイルを更新日時が古いもの順にオープンしたい
https://detail.chiebukuro.yahoo.co.jp/qa/questio …