あるフォルダーに複数のブック(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ベストアンサー
- 回答日時:
以下のマクロを標準モジュールに登録してください。
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
ありがとうございます。思った通りの順番に並べることができました。色々試してみるとシート名の頭に数字が振ってあれば数字順に並ぶようでしたがその他はどんな法則で並んでいるかがわかりませんでした。簡単に考えていたのですがこんなに長くて難しい記述が必要なのですね。
大変お手数をおかけいたしました。
No.3
- 回答日時:
VSTACK関数は使えない環境ですか?
No.2
- 回答日時:
こんばんは
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
お世話になっております。色々ありがとうございます。貼り付けて何度か実施してみましたがやはり作成日作成時間順に並びません。当方のやり方の問題があると思いますので自身で色々調べてみます。
No.1
- 回答日時:
こんばんは。
検索した記事ですが、下記のコードが参考になるかと思います。
●フォルダ内のファイルを更新日時が古いもの順にオープンしたい
https://detail.chiebukuro.yahoo.co.jp/qa/questio …
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) シートをコピーする下記記述でダイアログを用いた記述がわかりません?( A = Dir(ThisWor 4 2022/08/22 12:26
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- その他(Microsoft Office) マクロVBAについて 1 2022/09/06 18:12
- Visual Basic(VBA) 【前回の続き続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/24 20:49
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 1 2023/08/10 14:24
- Visual Basic(VBA) VBAが止まります。 1 2022/09/02 14:51
- Visual Basic(VBA) 別ブックからシートのコピー 3 2022/04/01 20:07
- Visual Basic(VBA) Excelのマクロコードについて教えてください 1 2022/03/27 12:02
- Visual Basic(VBA) Excelのマクロコードについて教えてください。 1 2022/03/27 13:25
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルを共有するとPCによっ...
-
VBAでブックを非表示で開いて処...
-
エクセルの関数 ENTERを押...
-
エクセルで参照しているデータ...
-
エクセルにおける,「ブック」...
-
Excelでブックの共有を掛けると...
-
Excelで複数ブックの同一セルに...
-
Excelファイルを開いても何も表...
-
「ブックの共有」を有効にして...
-
エクセル2016です。「ブッ...
-
エクセルで開いていないbookの...
-
フォルダ内の複数ファイルから...
-
複数ファイルから特定シートの...
-
エクセルシートの一部を送りたい
-
WorkBooksをオープンさせずにシ...
-
同じフォルダへのハイパーリン...
-
フォルダ内の複数ファイルから...
-
アクセスvbaでエクセルブックを...
-
【マクロ】【VBA】別ブックへの...
-
エクセルの複数シートをCSV...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBAでブックを非表示で開いて処...
-
エクセルを共有するとPCによっ...
-
エクセルの関数 ENTERを押...
-
エクセルで参照しているデータ...
-
WorkBooksをオープンさせずにシ...
-
Excelでブックの共有を掛けると...
-
【マクロ】【VBA】別ブックへの...
-
Excelで複数ブックの同一セルに...
-
エクセルにおける,「ブック」...
-
エクセルで50行ごとに区切った...
-
エクセルファイルを開かずにpdf...
-
Excel(2010)のフィルターが保...
-
エクセルで「ディスクがいっぱ...
-
エクセル2016です。「ブッ...
-
エクセルでウィンドウの枠固定...
-
外部ブック参照が#REF!になって...
-
エクセルで別ブックをバックグ...
-
エクセルシートの一部を送りたい
-
ブックのピボットを別ブックに...
-
複数ファイルから特定シートの...
おすすめ情報