Sub MergeAllExcelFiles()
Dim excelApp As Variant
Dim workBook As Variant
Dim workSheet As Variant
Dim sourceWorkbook As Variant
Dim sourceSheet As Variant
Dim fileSystem As Variant
Dim baseFolder As Variant
Dim folder As Variant
Dim file As Variant
Dim basePath As String
Dim targetPath As String
Dim lastRow As Integer
Dim folderName As String
Dim fileName As String
' Excelアプリケーションを起動
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True ' デバッグ用（不要なら False）
' Work.xlsx を開く（なければ作成）
targetPath = "C:\temp\Work.xlsx"
On Error Resume Next
Set workBook = excelApp.Workbooks.Open(targetPath)
If Err.Number <> 0 Then
Err.Clear
Set workBook = excelApp.Workbooks.Add
workBook.SaveAs targetPath
End If
On Error GoTo 0
Set workSheet = workBook.Sheets(1) ' メインのシートを選択
' ファイルシステムオブジェクトを作成
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set baseFolder = fileSystem.GetFolder("C:\temp") ' C:\temp フォルダのオブジェクト取得
' `C:\temp` 内のすべてのフォルダを取得
For Each folder In baseFolder.SubFolders
folderName = folder.Name
' フォルダ名が「20XX年」の形式であることを確認
If folderName Like "20??年" Then
' フォルダ内のファイルを取得
For Each file In folder.Files
fileName = file.Name
' Excel ファイルのみ処理
If LCase(Right(fileName, 5)) = ".xlsx" Then
' Excel ファイルを開く
Set sourceWorkbook = excelApp.Workbooks.Open(folder.Path & "\" & fileName)
Set sourceSheet = sourceWorkbook.Sheets(1) ' 1つ目のシートをコピー
' Work.xlsx の次の空いている行を探す
lastRow = workSheet.Cells(workSheet.Rows.Count, 1).End(-4162).Row + 1 ' xlUp の定数: -4162
' シートの内容をコピー＆ペースト
sourceSheet.UsedRange.Copy
workSheet.Cells(lastRow, 1).PasteSpecial -4163 ' xlPasteValues の定数
' ファイルを閉じる
sourceWorkbook.Close False
Set sourceSheet = Nothing
Set sourceWorkbook = Nothing
End If
Next
End If
Next
' 保存して終了
workBook.Save
workBook.Close
excelApp.Quit
' オブジェクト解放
Set workSheet = Nothing
Set workBook = Nothing
Set excelApp = Nothing
Set fileSystem = Nothing
Set baseFolder = Nothing
End Sub