よく利用するエクセルマクロ（複数シートの統合）
同じ様な内容を複数のシートに分けて管理していることがあると思います。ですが、これを統合して処理したい時、ひとつのシートにコピーするのが手間ですよね。
- 例1. データベースのテーブル情報をシート毎に管理 → データベース単位で管理したい
- 例2. 月次伝票情報をシート毎に管理 → 年次で管理したい
よって、複数のシートをひとつのシートに統合するエクセルマクロを作成しました。
ググって調査したのですがVBマクロの素人（私）には少し知識がいる様な内容が多かったので、見た目にわかりやすく（マクロの記憶機能で作った様なコードを少し汎用的に）作成しました。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
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でやり切る技術を得たかったのですが、調査するまでのやる気スイッチはなくなりました。(-_-;) いずれ機会があれば…