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

ブックにある複数のシートを1つのシートに縦にまとめるエクセルVBAをご紹介します。

次のサンプルコードを使うと、
<ul>
 	<li>「ファイルを開く」ダイアログを表示。</li>
 	<li>シートをまとめたいエクセルブックを選択。</li>
 	<li>選択したエクセルブックに、集約用シートを追加。</li>
 	<li>エクセルブックに含まれる全シートをコピー、集約用シートにまとめる。</li>
</ul>
という作業を自動化します。
<h2>処理イメージ</h2>
エクセルブック内にある複数シートをコピー、集約シートを追加して縦に貼り付けてまとめます。

<img class="alignnone size-full wp-image-361" src="http://www.wchack.com/hako001/wp-content/uploads/2019/05/001.png" alt="" width="1200" height="270" />
<h2>操作方法</h2>
1、
下記サンプルコードを含むエクセルファイルを開き→「開発」→「マクロ」の順でクリック。
「Aシート縦に集約」→「実行」の順でクリック。

<img class="alignnone size-full wp-image-369" src="http://www.wchack.com/hako001/wp-content/uploads/2019/05/001-1.png" alt="" width="804" height="507" />

2、
ファイルを開くダイアログが表示されるので、シートをまとめたい対象のエクセルブックをクリックして、「開く」をクリック。

<img class="alignnone size-full wp-image-370" src="http://www.wchack.com/hako001/wp-content/uploads/2019/05/002.png" alt="" width="755" height="473" />

3、
マクロが実行されます。
「集約シート」を追加、各シートをコピーして、
「集約シート」に各シートのデータを縦向きに貼り付けます。

<img class="alignnone size-full wp-image-371" src="http://www.wchack.com/hako001/wp-content/uploads/2019/05/003.png" alt="" width="1200" height="280" />

完了です。
<h2>サンプルコード</h2>
<pre class="lang:default decode:true ">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("シート「集約シート」を上書きしますか？" &amp; Chr(13) &amp; "※この処理は戻せません", 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 &lt;&gt; dWS.Name Then
                
                    With sWS.UsedRange
                        'シートsWSをアクティブにする
                        sWS.Activate
                    
                        'シートの最終セルを選択する
                        ActiveCell.SpecialCells(xlLastCell).Select
                        
                        '最終セルの行を取得、変数に代入
                        s_row = ActiveCell.row
        
                        '最終行から1行目までを選択
                        Rows(1 &amp; ":" &amp; 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 &lt;&gt; dWS.Name Then
                
                    With sWS.UsedRange
                        'シートsWSをアクティブにする
                        sWS.Activate
                    
                        'シートの最終セルを選択する
                        ActiveCell.SpecialCells(xlLastCell).Select
                        
                        '最終セルの行を取得、変数に代入
                        s_row = ActiveCell.row
        
                        '最終行から1行目までを選択
                        Rows(1 &amp; ":" &amp; 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


</pre>
<h2>コードの特徴</h2>
<ul>
 	<li>「ファイルを開く」ダイアログを表示した後、キャンセルをクリックした場合、
キャンセル処理される様に対応しています。</li>
 	<li>セル、行、列に空白がある場合でも、
シート毎のデータが含まれる最終行からA行までをコピーして集約します。</li>
 	<li>集約用にシート「集約シート」を作成します。
同名シートが既にある場合、同名シートを削除するかの確認ダイアログを表示させ、
削除するかどうかを選択可能です。</li>
</ul>