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

7237 ワード
VBA マクロ 効率化 自動化 Excel Excel テキストリンク

ブックにある複数のシートを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行までをコピーして集約します。

  • 集約用にシート「集約シート」を作成します。
    同名シートが既にある場合、同名シートを削除するかの確認ダイアログを表示させ、
    削除するかどうかを選択可能です。