Option Explicit
Sub フォルダ内の全集計ファイルを取りまとめる()
Dim フォルダパス As String
Dim 対象ファイル As String
Dim 対象ブック As Workbook
Dim 一時ブック As Workbook
Dim シート As Worksheet
Dim 合成シート As Worksheet
Dim 最終行 As Long
Dim 集計ファイル数 As Integer
Application.ScreenUpdating = False
' 新しいワークブックを作成
Set 一時ブック = Workbooks.Add
Set 合成シート = 一時ブック.Sheets(1)
' 合成シートの行数を初期化
最終行 = 1
' 対象フォルダのパスを取得
フォルダパス = "Z:\Work" ' <-- ここにフォルダのパスを入力してください
' フォルダ内のExcelファイルを処理
対象ファイル = Dir(フォルダパス & "\*.xlsx") ' フォルダ内のExcelファイルを取得
集計ファイル数 = 0
' ファイル名を格納する列のヘッダーを追加
'合成シート.Cells(1, 1).Value = "ファイル名"
Do While 対象ファイル <> ""
' Excelファイルを開く
Set 対象ブック = Workbooks.Open(フォルダパス & "\" & 対象ファイル)
' 「sheet1」という名前のシートが存在するかチェック
If WorksheetExists(対象ブック, "sheet1") Then
' 集計ファイル数をカウント
集計ファイル数 = 集計ファイル数 + 1
' ファイル名のみを取得
Dim ファイル名 As String
ファイル名 = 対象ファイル
' ファイル名を格納する行を取得
Dim 挿入行 As Long
挿入行 = 最終行
' ファイル名を挿入
合成シート.Cells(挿入行, 1).Value = ファイル名
' 集計ファイルのsheet1を合成シートにコピー
対象ブック.Sheets("sheet1").UsedRange.Copy 合成シート.Cells(挿入行, 2)
' 最終行の更新
最終行 = 挿入行 + 対象ブック.Sheets("sheet1").UsedRange.Rows.Count
End If
' 次のファイルへ
対象ブック.Close False
対象ファイル = Dir
Loop
' 合成データの書き込みが終了したので、合成ワークブックを保存
一時ブック.SaveAs フォルダパス & "\集計データ.xlsx"
' 合成ワークブックを閉じる
一時ブック.Close False
Application.ScreenUpdating = True
MsgBox "集計が完了しました。" & vbCrLf & "フォルダ内の「sheet1」のシート数: " & 集計ファイル数, vbInformation
End Sub
Function WorksheetExists(wb As Workbook, sName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(sName)
On Error GoTo 0
WorksheetExists = Not ws Is Nothing
End Function
