同じフォーマットのシートが複数あると集約が必要になる
事務作業でよくあるのが、同じフォーマットで複数のシートに入力する作業です。例えば、月ごとや日ごとの在庫管理シートや、売上管理の担当者シートなどです。
そしてそのようなブックを扱っていると後になって必要になるのが、複数シートの集約です。１年分にまとめたい、とか、全担当者分をまとめたい、とかですね。
このようなフォーマットは組織ごとに異なるため、集約方法にも当然のように違いがあるためそれら全てに対応することは出来ませんが、「全シートを１つにまとめたい」という目的は大体同じなので、ここではどのようなブックでも扱える「集約」に特化したコードを紹介します。
全シートの内容を新しいブックで１つにまとめる
以下のコードを実行すると、全シートの内容を新規ブックを作成して１つのシートに全て貼り付けます。
関数が３つありますが、実行するのはMergeSheets()です。残りの２つはMergeSheets()から呼び出されるサブ関数です。
処理内容はコメントに大体書いていますが、考え方について補足します。
まず、まとめたいシートがあるブックを選択しておきます。そしてMergeSheets関数を実行すると、GetSheetData関数の中でコピー元の全シートをループして、各シートのセル入力範囲の内容をRangeオブジェクトとして取得します。取得はRangeオブジェクト配列（変数ar）に格納します。セル入力範囲の判定はUsedRangeを使っているため、シートごとにフォーマットが同じでも異なっていても、セル入力範囲は全てコピー対象になります。
その後、OutputData関数に全シートのデータ（配列ar）を渡して呼び出し、新規ブックを作成して、一番左のシートの上から順に全シートの内容が張り付けられます。
張り付ける順番は元のシートの左から順です。例えば、「1月」「2月」「3月」というシートが左から順にある場合は、新規ブックのシートには上から順に「1月」の内容、「2月」の内容、「3月」の内容が張り付けられます。
なお、コピーしたくないシートがある場合は、GetSheetData関数のsExcList変数にそのシート名を書いておけばコピーの対象にならないようにしています。そのようなコピーから除外したいシートが複数ある場合はコロン（:）でシート名を区切ってください。例えば、「1月」から「12月」までの12個のシートがある場合に、「4月」と「5月」と「12月」のシートをコピーしたくない場合は、「sExcList = “4月:5月:12月”」としてください。除外したいシートが１つだけの場合はコロンは不要です。
以下のコードでは元のシートの書式や値を全てコピーしていますが、値だけを張り付けたい場合はコメントアウトしている.Valueのコードを使えばそのようになります。
|
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 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
Sub MergeSheets() Dim ar() As Range '// シートのセル範囲配列 ReDim ar(0) '// 全シートのデータを取得 Call GetSheetData(ar) '// 取得した全シートのデータを新規ブックにまとめて出力する Call OutputData(ar) End Sub '// 全シートのセル範囲をシート毎に配列で取得 Sub GetSheetData(ar() As Range) Dim sExcList As String '// 除外するシート名リスト（複数時はコロン区切り："aa:bb"） Dim v As Variant '// 除外シート名の配列 sExcList = "Sheet1:Sheet1 (3)" '// sExcList = "" '// 除外シートを配列化 v = Split(sExcList, ":") Dim ws As Worksheet '// ワークシート '// 全シートをループ For Each ws In Worksheets Dim ex '// 除外シート '// 除外シートを全てループ For Each ex In v '// 除外対象のシートの場合は次のシートへ If ex = ws.Name Then GoTo CONTINUE End If Next '// シートの入力セル範囲のRangeオブジェクトを取得 Set ar(UBound(ar)) = ws.UsedRange ReDim Preserve ar(UBound(ar) + 1) CONTINUE: Next '// 配列が設定されていれば余分な空要素を削除する If IsEmpty(ar(0)) <> True Then ReDim Preserve ar(UBound(ar) - 1) End If End Sub '// セル範囲配列の内容を新規ブックに貼り付け Sub OutputData(ar() As Range) Dim wb As Workbook '// 新規ブック Dim ws As Worksheet '// 新規ブックのシート '// 新規ブックを作成 Set wb = Workbooks.Add '// 新規ブックのシートを参照 Set ws = wb.Worksheets(1) Dim r As Range '// セル範囲 Dim i As Integer '// インデックス '// セル範囲配列をループ For i = 0 To UBound(ar) Set r = ar(i) '// ループ初回 If i = 0 Then '// 1行目に貼り付け '// 値だけをはりつける場合はこちら 'ws.Range(r.Address).Value = r.Value '// セルの書式と値の両方を張り付け r.Copy Call ws.Range(r.Address).PasteSpecial(xlPasteAll) '// ループ２回目以降 Else '// 入力済み行の１行下に貼り付け '// 値だけをはりつける場合はこちら 'ws.UsedRange.Offset(ws.UsedRange.Rows.Count, 0).Range(r.Address).Value = r.Value '// セルの書式と値の両方を張り付け r.Copy Call ws.UsedRange.Offset(ws.UsedRange.Rows.Count, 0).Range(r.Address).PasteSpecial(xlPasteAll) End If Next End Sub |
使い方
使い方ですが、集約したいシートのブックを表示させて、GetSheetData関数を実行するだけです。実行すると、新規ブックの一番左のシートに集約されます。
なお、新規ブックの保存は行わないため、それは手で保存してください。保存処理を入れたい場合は「VBAでブックに名前を付けて保存する（SaveAs）」をご参照ください。
以下は使い方の例です。シートが５つあり、２つのシートをコピーから除外するようにしています。除外したいシートは上で書いている通りですが変数sExcListに記述しておきます。ここでは「sExcList = “Sheet1:Sheet1 (3)”」としています。
元の５つのシートが以下です。それぞれ行数が異なり、また、罫線やテーブルの種類も異なります。４つ目のシートは列数を変えています。
GetSheetData関数実行後に新規ブックに以下のように集約されます。元のシートの書式がそのままで反映されます。２つのシートが含まれていないのは変数sExcListで除外しているためです。
自動で保存はしていませんので手で保存してください。