よく利用するエクセルマクロ(複数シートの統合)

同じ様な内容を複数のシートに分けて管理していることがあると思います。ですが、これを統合して処理したい時、ひとつのシートにコピーするのが手間ですよね。

  • 例1. データベースのテーブル情報をシート毎に管理 → データベース単位で管理したい
  • 例2. 月次伝票情報をシート毎に管理 → 年次で管理したい

よって、複数のシートをひとつのシートに統合するエクセルマクロを作成しました。

ググって調査したのですがVBマクロの素人(私)には少し知識がいる様な内容が多かったので、見た目にわかりやすく(マクロの記憶機能で作った様なコードを少し汎用的に)作成しました。

Sub copy_from_all_sheet()
    Dim sWS As Worksheet  'データシート(コピー元)
    Dim dWS As Worksheet  '統合用シート(コピー先)
  
    '事前にAllDataと言うシートを追加していること
    Set dWS = Worksheets("AllData")
    '統合用シートの内容削除(オフセットあり、ここではオフセット1(1行目はタイトル部を想定))
    dWS.UsedRange.Offset(1, 0).Clear
    '統合用シートの貼り付け開始位置(先頭と後尾は特定の文字あり)
    first_row = 2
    maxrow = 1 + first_row
    maxrow_next = 0
    sheetName = ""
    maxcol = 0
    '各シートを、統合用シートの後尾にコピー
    For Each sWS In Worksheets
        '統合用シートでない場合
        If sWS.Name <> dWS.Name Then
            With sWS.UsedRange
                '利用範囲の取得
                irow = sWS.UsedRange.Rows(sWS.UsedRange.Rows.Count).Row
                icol = sWS.UsedRange.Columns(sWS.UsedRange.Columns.Count).Column
            End With
            'シートアクティブにする
            sWS.Activate
            'シート名の取得
            sheetName = sWS.Name
            'シートのコピー
            sWS.Range(sWS.Cells(1, 1), sWS.Cells(irow, icol)).Copy
            '統合用シートをアクティブにする
            dWS.Activate
            maxrow_next = maxrow + irow
            '1列目はシート名にする
            Range(Cells(maxrow, 1), Cells(maxrow_next - 1, 1)) = sheetName
            '2列目を選択する
            Cells(maxrow, 2).Select
            '貼り付けを実施する
            ActiveSheet.Paste
            '1行の間隔をあけたい場合 (+ 0 → + 1)
            '統合用シートの貼り付け行の保持
            maxrow = maxrow_next + 0
            '最大列の保持
            If maxcol < icol Then
                maxcol = icol
            End If
        End If
    Next sWS
    
    '統合後の先頭と最下部に文字を記載
    Range(Cells(first_row, 1), Cells(first_row, maxcol + 1)) = "STA"
    Range(Cells(maxrow, 1), Cells(maxrow, maxcol + 1)) = "EOF"
    
    '統合後の複数シート範囲にフィルターを追加
    Cells(first_row, 1).Select
    Selection.End(xlToLeft).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter
    
End Sub

上記マクロを動かすためには、AllDataと言うシートを作成しておいてください。これが複数シートの統合先になります。

正直、Rangeはプログラムで使いづらいですよね。Cellsでやり切る技術を得たかったのですが、調査するまでのやる気スイッチはなくなりました。(-_-;) いずれ機会があれば…