VBA シートまとめる

Option Explicit

 Sub SheetUnion()

Dim i As Integer 'ループ用
'i = 0

'ファイル名をシート名にする。注："-4"とは".xls"の4文字分を除くため。
Dim Filename As String
Filename = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)


'1枚目のシートに"ワークブック名"シートをつくる。
Worksheets.Add Before:=Worksheets(1)
Worksheets(1).Name = Filename

For i = 2 To Sheets.Count '2枚目から最後のシートまで取り込む

'/* コピー元の情報を取得 */
Const START_ROW_SRC As Long = 2 'コピー範囲の開始行
Const START_COL_SRC As Integer = 1 'コピー範囲の開始列
Const END_COL_SRC As Integer = 13 'コピー範囲の終了列

Const BOOK_NAME_COL As Integer = 1 'ブック名の列
Const SHEET_NAME_COL As Integer = 2 'シート名の列

Dim endRowSrc As Long 'コピー範囲の終了行（動的に変化する）

'最終行
With ThisWorkbook.Sheets(i)
endRowSrc = .Cells(.Rows.Count, 1).End(xlUp).row 'Rows.Count = 65536
End With


'/* コピー先の情報を取得 */

'コピー先のシート
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Sheets(Filename)

'コピー先の行列
Const DST_COl As Integer = 3 'コピー先の列
Dim START_ROW_DST As Long 'コピー先の開始行（動的に変化する）
Dim endRowDst As Long 'コピー先の終了行（動的に変化する）

With wsDst
    '最初の行
    START_ROW_DST = .Cells(.Rows.Count, 1).End(xlUp).row + 1
    '最終行
    endRowDst = START_ROW_DST + endRowSrc - START_ROW_SRC
End With

'コピー元からコピー先にコピー
With ThisWorkbook.Sheets(i)
    .Range(.Cells(START_ROW_SRC, START_COL_SRC), .Cells(endRowSrc, END_COL_SRC)).Copy Destination:=wsDst.Cells(START_ROW_DST, DST_COl)
End With

'ブック名を入力
With wsDst
    .Range(.Cells(START_ROW_DST, BOOK_NAME_COL), .Cells(endRowDst, BOOK_NAME_COL)).Value = Filename
End With

'シート名を入力
With wsDst
    .Range(.Cells(START_ROW_DST, SHEET_NAME_COL), .Cells(endRowDst, SHEET_NAME_COL)).Value = ThisWorkbook.Sheets(i).Name
End With

Next i

wsDst.Activate 'コピー先のシートをアクティブにする

MsgBox ("正常終了")

End Sub