ブックにある複数のシートを1つのシートに縦にまとめるエクセルVBAをご紹介します。
次のサンプルコードを使うと、
- 「ファイルを開く」ダイアログを表示。
- シートをまとめたいエクセルブックを選択。
- 選択したエクセルブックに、集約用シートを追加。
- エクセルブックに含まれる全シートをコピー、集約用シートにまとめる。
という作業を自動化します。
処理イメージ
エクセルブック内にある複数シートをコピー、集約シートを追加して縦に貼り付けてまとめます。
操作方法
1、
下記サンプルコードを含むエクセルファイルを開き→「開発」→「マクロ」の順でクリック。
「Aシート縦に集約」→「実行」の順でクリック。
2、
ファイルを開くダイアログが表示されるので、シートをまとめたい対象のエクセルブックをクリックして、「開く」をクリック。
3、
マクロが実行されます。
「集約シート」を追加、各シートをコピーして、
「集約シート」に各シートのデータを縦向きに貼り付けます。
完了です。
サンプルコード
Sub Aシート縦に集約()
Dim sWS As Worksheet 'データシート
Dim dWS As Worksheet '集約用シート
Dim s_row As Long 'データシートの最終行数
Dim d_row As Long '集約用シートの最終行数
Dim OpenFileName As String
'ファイルを開くダイアログを表示
OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*")
'キャンセル時の処理
If OpenFileName = "False" Then
'メッセージ表示
MsgBox "キャンセルされました。処理を終了します。"
End
Else
Workbooks.Open OpenFileName
End If
'画面更新停止
Application.ScreenUpdating = False
'確認ダイアログ停止
Application.DisplayAlerts = False
'集約シートがあるか確認
For Each sh In Sheets
If sh.Name = "集約シート" Then
flag = True
Exit For
End If
Next sh
If flag = True Then
Dim rc As Integer
'メッセージ表示
rc = MsgBox("シート「集約シート」を上書きしますか？" & Chr(13) & "※この処理は戻せません", vbYesNo + vbQuestion, "確認")
If rc = vbYes Then
'画面更新停止
Application.ScreenUpdating = False
'シート選択
Worksheets("集約シート").Activate
'シート削除
ActiveSheet.Delete
'画面更新停止
Application.ScreenUpdating = True
'メッセージ表示
MsgBox "処理前のシート「集約シート」は削除済みです"
'シート追加
Worksheets.Add before:=Worksheets(1)
'シート名変更
ActiveSheet.Name = "集約シート"
'シート選択
Worksheets("集約シート").Activate
Set dWS = Worksheets("集約シート")
'ブックを上書き保存
ActiveWorkbook.Save
'集約用シートの最終行数に1を代入
d_row = 1
'各シートにコードを実行
For Each sWS In Worksheets
'sWSとdWSのシート名が一致しない場合
If sWS.Name <> dWS.Name Then
With sWS.UsedRange
'シートsWSをアクティブにする
sWS.Activate
'シートの最終セルを選択する
ActiveCell.SpecialCells(xlLastCell).Select
'最終セルの行を取得、変数に代入
s_row = ActiveCell.row
'最終行から1行目までを選択
Rows(1 & ":" & s_row).Select
'最終行から1行目までをコピー
Selection.Copy
'集約用シートを選択
dWS.Activate
'行を選択
Rows(d_row).Select
'コピーしたデータを貼り付け
ActiveSheet.Paste
'シートの最終セルを選択する
ActiveCell.SpecialCells(xlLastCell).Select
'最終セルの行を取得、変数に代入
d_row = ActiveCell.Offset(1, 0).row
End With
End If
Next sWS
Else
'メッセージ表示
MsgBox "キャンセルされました。処理を終了します。"
End If
Else
'シート追加
Worksheets.Add before:=Worksheets(1)
'シート名変更
ActiveSheet.Name = "集約シート"
'シート選択
Worksheets("集約シート").Activate
Set dWS = Worksheets("集約シート")
'集約用シートのセルを全削除
Worksheets("集約シート").Cells.Select
Selection.Delete Shift:=xlUp
'ブックを上書き保存
ActiveWorkbook.Save
'集約用シートの最終行数に1を代入
d_row = 1
'各シートにコードを実行
For Each sWS In Worksheets
'sWSとdWSのシート名が一致しない場合
If sWS.Name <> dWS.Name Then
With sWS.UsedRange
'シートsWSをアクティブにする
sWS.Activate
'シートの最終セルを選択する
ActiveCell.SpecialCells(xlLastCell).Select
'最終セルの行を取得、変数に代入
s_row = ActiveCell.row
'最終行から1行目までを選択
Rows(1 & ":" & s_row).Select
'最終行から1行目までをコピー
Selection.Copy
'集約用シートを選択
dWS.Activate
'行を選択
Rows(d_row).Select
'コピーしたデータを貼り付け
ActiveSheet.Paste
'シートの最終セルを選択する
ActiveCell.SpecialCells(xlLastCell).Select
'最終セルの行を取得、変数に代入
d_row = ActiveCell.Offset(1, 0).row
End With
End If
Next sWS
End If
End Sub
コードの特徴
- 「ファイルを開く」ダイアログを表示した後、キャンセルをクリックした場合、
キャンセル処理される様に対応しています。 - セル、行、列に空白がある場合でも、
シート毎のデータが含まれる最終行からA行までをコピーして集約します。 - 集約用にシート「集約シート」を作成します。
同名シートが既にある場合、同名シートを削除するかの確認ダイアログを表示させ、
削除するかどうかを選択可能です。