複数のシートをコピーして1つのシートに縦にまとめるエクセルVBA

ブックにある複数のシートを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行までをコピーして集約します。
• 集約用にシート「集約シート」を作成します。 同名シートが既にある場合、同名シートを削除するかの確認ダイアログを表示させ、 削除するかどうかを選択可能です。