フォルダ内のブックを指定したブックのシートとしてまとめる。

★指定したフォルダ内のブックにおいて、現在開いているアクティブシートのA列にまとめたい新規のブック名（拡張子付き）を登録、Ｂ列にそのブックにもっていきたい（そのフォルダ内の）ブック名（拡張子付き）を登録しておく★

Sub 指定ブックをシートに登録()
Dim folderPath As String
Dim fileName As String
Dim sheetName As String
Dim targetWorkbook As Workbook
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim cell As Range
Dim ws As Worksheet
Dim totalFiles As Long
Dim processedFiles As Long

' フォルダのパスを入力
folderPath = InputBox("操作対象になるフォルダのパスを入力してください", "フォルダの選択")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

' 画面の更新を停止
Application.ScreenUpdating = False

' 処理対象のファイル数をカウント
totalFiles = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(rows.Count, 1).End(xlUp).row).Count
processedFiles = 0

' A列の各セルをループ
For Each cell In ActiveSheet.Range("A1:A" & ActiveSheet.Cells(rows.Count, 1).End(xlUp).row)
    fileName = cell.Value
    sheetName = Left(cell.Offset(0, 1).Value, InStrRev(cell.Offset(0, 1).Value, ".") - 1)

    ' ターゲットブックが存在するか確認し、存在しなければ作成
    On Error Resume Next
    Set targetWorkbook = Workbooks.Open(folderPath & fileName)
    If Err.Number <> 0 Then
        Set targetWorkbook = Workbooks.Add
        targetWorkbook.SaveAs folderPath & fileName
    End If
    On Error GoTo 0

    ' ソースブックを開く
    Set sourceWorkbook = Workbooks.Open(folderPath & cell.Offset(0, 1).Value)

    ' ソースブックに複数シートがある場合はエラーを表示して停止
    If sourceWorkbook.Sheets.Count > 1 Then
        MsgBox "エラー: " & sourceWorkbook.Name & " に複数のシートがあります。処理を中止します。"
        sourceWorkbook.Close False
        targetWorkbook.Close False
        Exit Sub
    End If

    Set sourceSheet = sourceWorkbook.Sheets(1)

    ' ソースシートをターゲットブックにコピー
    sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
    targetWorkbook.Sheets(targetWorkbook.Sheets.Count).Name = sheetName

    ' ソースブックを保存せずに閉じる
    sourceWorkbook.Close False

    ' 空白のシートを削除
    For Each ws In targetWorkbook.Sheets
        If WorksheetFunction.CountA(ws.Cells) = 0 Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws

    ' 各シートを100%表示にし、A1セルにフォーカスを当てる
    For Each ws In targetWorkbook.Sheets
        ws.Activate
        ActiveWindow.Zoom = 100
        ws.Cells(1, 1).Select
    Next ws

    ' 一番左のシートをアクティブにする
    targetWorkbook.Sheets(1).Activate

    ' ターゲットブックを保存して閉じる
    targetWorkbook.Close True

    ' 進捗状況を更新
    processedFiles = processedFiles + 1
    Application.StatusBar = "進捗: " & Format(processedFiles / totalFiles, "0%") & " 完了"
Next cell

' 画面の更新を再開
Application.ScreenUpdating = True
Application.StatusBar = False

MsgBox "シートの登録が完了しました！"

End Sub