全ファイル結合（とあるファイル専用）

Sub Button1_Click()
Const cnsYEN = "\"
Dim xlAPP As Application ' Excel.Application
Dim objFS As FileSearch ' FileSearch
Dim objFSO As FileSystemObject ' FSO
Dim objWBK As Workbook ' 処理ブック
Dim objSH As Worksheet ' 処理シート
Dim vntF As Variant ' 発見したファイル名の配列
Dim strPATHNAME As String ' 指定フォルダ名
Dim strFILENAME As String ' 検出したファイル名
Dim tblSH As Variant ' 表示シートの配列を格納
Dim IX As Long ' WORK
Dim swESC As Boolean ' Escキー判定
Dim activeFN As String ' このブック名
Dim rowCnt As Integer ' 行カウンタ

' 「フォルダの参照」よりフォルダ名の取得(modAPIBrowseForFolder2に収容)
strPATHNAME = BrowseForFolder("フォルダを指定して下さい", True)
If strPATHNAME = "" Then Exit Sub

Set xlAPP = Application
With xlAPP
.ScreenUpdating = False ' 画面描画停止
.EnableEvents = False ' イベント動作停止
.EnableCancelKey = xlErrorHandler ' Escキーでエラートラップする
End With ' このブック名の退避

activeFN = ActiveWorkbook.Name
Sheets("マージ集計").Activate
DeleteContents.Delete_All

' 指定フォルダ内のExcelブックを順次処理
Set objFS = xlAPP.FileSearch
Set objFSO = New FileSystemObject
With objFS
.LookIn = strPATHNAME ' Search開始フォルダ
.Filename = "*.xls" ' 探索ファイル式
.SearchSubFolders = True ' サブフォルダも探索
' 処理開始
If .Execute() = 0 Then
MsgBox "このフォルダにはExcelワークブックは存在しません。"
GoTo Button1_Click_EXIT
End If

' 見つかったファイル分のループ
For Each vntF In .FoundFiles ' Escキー打鍵判定
DoEvents
If swESC = True Then
' 中断するのかをメッセージで確認
If MsgBox("中断キーが押されました。ここで終了しますか？", _
vbInformation + vbYesNo) = vbYes Then
GoTo Button1_Click_EXIT
Else
swESC = False
End If
End If

xlAPP.StatusBar = vntF
' FSOにてファイルを取得
With objFSO.GetFile(vntF)
' ワークブックを開く(読み取り専用)
Set objWBK = Workbooks.Open( _
Filename:=.Path, UpdateLinks:=False, ReadOnly:=True)
'---------------------------------------------------------------
' ↓↓↓ 検索した１ファイル単位の処理 ↓↓↓
' シートのコピー(機能構成表)
objWBK.Sheets("機能構成表01").Copy After:= _
Workbooks(activeFN).Sheets(Workbooks(activeFN).Sheets.Count)
' 開いたブックをClose
objWBK.Close SaveChanges:=False

' カテゴリの列があったりなかったりするので調整（列追加）
Workbooks(activeFN).Sheets("XXXXXXX").Activate

Do While Cells(1, 5) = "" And Cells(2, 5) = ""
Columns("C:C").Select
Selection.Insert
Shift:=xlToRight
Cells(1, 3) = "ダミーカテゴリ" ' 列名

Loop Cells(1, 1).CurrentRegion.Copy

Sheets("マージ集計").Activate
rowCnt = Range("E65536").End(xlUp).Row
Cells(rowCnt + 2, 6) = .Name
Cells(rowCnt + 1, 1).Select
Selection.PasteSpecial

If rowCnt > 1 Then
Rows(rowCnt + 1).Delete Shift:=xlUp
End If

Sheets("XXXXXXX").Activate
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
' ↑↑↑ 検索した１ファイル単位の処理 ↑↑↑
'---------------------------------------------------------------
End With
Next vntF
End With
GoTo Button1_Click_EXIT

'----------------
' Escキー脱出用行ラベル
Button1_Click_ESC:
If Err.Number = 18 Then
' EscキーでのエラーRaise
swESC = True
Resume
ElseIf Err.Number = 1004 Then
' 隠しシートや印刷対象なしの実行時エラーは無視
Resume Next Else
' その他のエラーはメッセージ表示後終了
MsgBox Err.Description
End If

'----------------
' 処理終了
Button1_Click_EXIT:
EditHeader.Edit
With xlAPP
.StatusBar = False ' ステータスバーを復帰
.EnableEvents = True ' イベント動作再開
.EnableCancelKey = xlInterrupt ' Escキー動作を戻す
.Cursor = xlDefault ' カーソルをデフォルトにする
.ScreenUpdating = True ' 画面描画再開
End With
Set objWBK = Nothing
Set objFSO = Nothing
Set objFS = Nothing
Set xlAPP = Nothing
End Sub