Sub CombineSheets()
Dim wb As Workbook
Dim ws As Worksheet
Dim destWs As Worksheet
Dim lastRow As Long
Dim fileName As String
Dim isFirstSheet As Boolean
' ファイル選択ダイアログを表示
fileName = Application.GetOpenFilename("Excel ファイル (*.xlsx), *.xlsx", , "コピーするブックを選択してください")
' キャンセルされた場合は終了
If fileName = "False" Then Exit Sub
' 選択されたブックを開く
Set wb = Workbooks.Open(fileName, ReadOnly:=True)
' マクロブックのシート1を取得
Set destWs = ThisWorkbook.Sheets(1)
' マクロブックのシート1をクリア
destWs.Cells.Clear
isFirstSheet = True
lastRow = 1
' 各シートのデータをコピー
For Each ws In wb.Worksheets
If isFirstSheet Then
' 1つ目のシートは全行コピー
ws.UsedRange.Copy destWs.Cells(lastRow, 1)
lastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row + 1
isFirstSheet = False
Else
' 2つ目以降のシートは2行目からコピー
If ws.UsedRange.Rows.Count > 1 Then
ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1).Copy destWs.Cells(lastRow, 1)
lastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row + 1
End If
End If
Next ws
' 元のブックを閉じる
wb.Close SaveChanges:=False
MsgBox "全シートのデータがコピーされました。", vbInformation
End Sub
Sub CombineSheets()
Dim wb As Workbook
Dim ws As Worksheet
Dim destWs As Worksheet
Dim lastRow As Long
Dim fileName As String
Dim isFirstSheet As Boolean
Dim startTime As Double
' 処理時間の計測開始
startTime = Timer
' ファイル選択ダイアログを表示
fileName = Application.GetOpenFilename("Excel ファイル (*.xlsx), *.xlsx", , "コピーするブックを選択してください")
' キャンセルされた場合は終了
If fileName = "False" Then Exit Sub
' パフォーマンス最適化の設定
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
' 選択されたブックを読み取り専用で開く
Set wb = Workbooks.Open(fileName, ReadOnly:=True)
' マクロブックのシート1を取得
Set destWs = ThisWorkbook.Sheets(1)
' マクロブックのシート1をクリア
destWs.Cells.Clear
isFirstSheet = True
lastRow = 1
' 各シートのデータをコピー
For Each ws In wb.Worksheets
If isFirstSheet Then
' 1つ目のシートは全行コピー
ws.UsedRange.Copy destWs.Cells(lastRow, 1)
lastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row + 1
isFirstSheet = False
Else
' 2つ目以降のシートは2行目からコピー
If ws.UsedRange.Rows.Count > 1 Then
ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1).Copy destWs.Cells(lastRow, 1)
lastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row + 1
End If
End If
Next ws
' 元のブックを閉じる
wb.Close SaveChanges:=False
' パフォーマンス最適化の設定を元に戻す
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
' 処理時間の計算
Dim elapsedTime As Double
elapsedTime = Timer - startTime
MsgBox "全シートのデータがコピーされました。" & vbNewLine & _
"処理時間: " & Format(elapsedTime, "0.00") & " 秒", vbInformation
End Sub