はりつけ

Sub CopyDataFromMultipleWorkbooks()
' 変数宣言
Dim wsTemplate As Worksheet, wsNew As Worksheet
Dim wbSource As Workbook
Dim strFolderPath As String, strFileName As String
Dim selectedMonth As String
Dim targetColumn As Integer

' ユーザーに月名の入力を求める
selectedMonth = Application.InputBox("シート名を指定してください（例: 1月、2月）", Type:=2)

' 雛形シートを複製し、新しいシート名をユーザーが選択した月名に設定
Set wsTemplate = ThisWorkbook.Sheets("雛形シート")
wsTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set wsNew = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wsNew.Name = selectedMonth

' データ読み込み用のフォルダパスを設定
strFolderPath = ThisWorkbook.Path & "\reply\"
strFileName = Dir(strFolderPath & "*.xlsx")

' 初期列（B列）の設定
targetColumn = 2

' フォルダ内のすべてのワークブックを処理
Do While strFileName <> ""
Set wbSource = Workbooks.Open(strFolderPath & strFileName)

' 対象のワークブックに選択された月のシートがあるか確認
If SheetExists(selectedMonth, wbSource) Then
' AB列のデータを新しいシートにコピー
wsNew.Cells(1, targetColumn).Value = wbSource.Name
wbSource.Sheets(selectedMonth).Range("AB2:AB" & wbSource.Sheets(selectedMonth).Cells(Rows.Count, "AB").End(xlUp).Row).Copy
wsNew.Cells(2, targetColumn).PasteSpecial Paste:=xlPasteValues

' 次の列へ移動
targetColumn = targetColumn + 1
End If

' ワークブックを閉じる
wbSource.Close False
strFileName = Dir
Loop

' コピー操作終了後のクリーンアップ
Application.CutCopyMode = False
MsgBox "データのコピーが完了しました。"
End Sub

' シートが存在するかどうかを確認する関数
Function SheetExists(sheetName As String, wb As Workbook) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sheetName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function