여러 시트를 복사하여 하나의 시트로 세로로 묶는 엑셀 VBA

책에 있는 여러 시트를 하나의 시트에 세로로 정리하는 엑셀 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 행까지 복사하여 집계합니다.

집계를 위해 시트 "집계 시트"를 만듭니다.
같은 이름의 시트가 이미 있으면 같은 이름의 시트를 삭제할지 묻는 대화 상자가 표시됩니다.
삭제할지 여부를 선택할 수 있습니다.