excel シートまとめ

Attribute VB_Name = "Module1"
'機能：2枚目から最後のシートの内容をシート「まとめ」にコピーする
'作成日：2012/3/13
'作成者：
'更新履歴：2012/3/13 Ver0.5 初版作成

Option Explicit

Public Sub SheetUnion()

On Error GoTo Err_Trap

Dim i As Integer 'ループ用
i = 0
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 = 3 'コピー範囲の終了列
Const SHEET_NAME_COL As Integer = 1 'シート名の列
Dim endRowSrc As Long 'コピー範囲の終了行（動的に変化する）
'最終行
With ThisWorkbook.Sheets(i)
endRowSrc = .Cells(.Rows.Count, 1).End(xlUp).row
End With

'/* コピー先の情報を取得 */
'コピー先のシート
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Sheets("まとめ")
'コピー先の行列
Const DST_COl As Integer = 2 'コピー先の列
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
'コピー先の最大行チェック
If maxRowCheck(START_ROW_DST) = False Then
MsgBox "コピー先の開始行がExcelの最大行[ " & .Rows.Count & " ]を超えています", vbCritical, "エラー"
GoTo Exit_Trap
ElseIf maxRowCheck(endRowDst) = False Then
MsgBox "コピー先の最終行がExcelの最大行[ " & .Rows.Count & " ]を超えています", vbCritical, "エラー"
GoTo Exit_Trap
End If
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, SHEET_NAME_COL), .Cells(endRowDst, SHEET_NAME_COL)).Value = ThisWorkbook.Sheets(i).Name
End With

Next i

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

MsgBox ("正常終了")

Exit_Trap:
Set wsDst = Nothing 'メモリ開放
Exit Sub

Err_Trap:
MsgBox ("予期せぬエラーが発生しました。" & vbCrLf _
& Err.Number & "：" & Err.Description)
GoTo Exit_Trap

End Sub

'Excelの最大行チェック
Private Function maxRowCheck(ByVal row As Long) As Boolean

On Error GoTo Err_Trap

maxRowCheck = False

If maxRowCheck > Rows.Count Then
maxRowCheck = False
Else
maxRowCheck = True
End If

Exit_Trap:
Exit Function

Err_Trap:
MsgBox (Err.Number & "：" & Err.Description)
GoTo Exit_Trap

End Function