｢シート集約マクロ｣のレシピ

｢１つのExcelで複数シート管理｣
日常使いでは苦労する場面がありませんか？

１つのExcelブックで複数のシートを管理する。
こんな使い方をされている方も少なくないはずです。
Excelブックの数が減る分、ドキュメント管理は簡単になるかもですが、
日常使いでは、少し苦労する場面があるのではないでしょうか。
例えば、

• ブック全体のデータを集計・分析したいとき

• 中身を整理したいとき　などなど

複数シートを使うことで、日常使い、とりわけ見栄えが良くなりますが
いざ、データを集計する際に、整理の段階で四苦八苦する羽目に…
ショートカットキーを駆使して、切り貼り作業で時間が溶ける。
わたし自身、こんな経験が結構ありました。笑

今回はそんなときに使える、とっておきのExcelマクロ
「シートを自動集約するマクロ」をご紹介します！

---

１．マクロの説明と使い方

Excelマクロで、ブック内の複数シートを１つのシートに集約するよ。
集計とかデータ整理したいときに、１つの表データとした方が、作業が進めやすいと。是非、使ってみてね！

図１：マクロの動作イメージ

これを例にすると、日付毎のシートにあるデータを先頭のシートにひと纏めにするマクロだよ。

２．マクロを使うための手順

シート集約マクロを使うための手順を整理するよ。
ソースコードは最後にまとめてるから、参考にしてね！

---

1. マクロのソースコードを標準モジュールにコピペ

2. 複数シートの体裁(フォーマット)を整える

3. マクロを使う　名前丨combSheetsData

---

１．マクロのソースコードを標準モジュールにコピペ
> 開発タブ > Visual Basic > 標準モジュール > ソースをコピペ

図２：ソースコードのコピペ手順

２．複数シートの体裁(フォーマット)を整える

各シートの体裁を統一しておく必要があるよ。
例えば、どのシートでもB列 ＝ 品目名 で整理しておく

図３：シートの体裁イメージと注意点

３．マクロを使う　マクロ名丨combSheetsData
> 開発タブ > マクロ > マクロ名丨combSheetsData > 実行

図４：マクロの実行手順

３．マクロを使うときの注意点

マクロを使う際は、以下のことに注意してください。

• マクロの実装および実行はすべて自己責任で行ってください。

• 開発環境は、Windows OS 64bit が対象になります。

• マクロには特定のシートを作成・削除するコードが含まれています。

• 参照元シートの先頭見出しは、セルA1である必要があります。

• 参照元シートの体裁は整えて置く必要があります。

• 集計データには、参照元の各シート名を追加します。

４．Excel VBAのソースコード

Option Explicit

Sub CombSheetsData()
'--------------------------------
' findMe: ブック内のシートデータを結合する
' name: テラ｜RPA×静かな退職
' instagram: @tera.rpaer
'--------------------------------
' cau: マクロの実装及び実行はすべて自己責任でお願いします。
' cau: 各シートのフォーマットは統一する必要があります。
' cau: only WindowsOS Excel 64bit
'--------------------------------

Const shName = "集計データです byテラ"

Dim wsList As Worksheet: Set wsList = AddSh(shName)
Dim wsSearch As Worksheet
Dim arrList As Variant
Dim mRow As Long: mRow = 1
Dim isTitle As Long: isTitle = 0

With wsList
    .Activate
    For Each wsSearch In Worksheets
    If Not wsSearch.Name Like shName Then
        Application.DisplayAlerts = False
        arrList = getArr2D(wsSearch.Name, isTitle)
        If isTitle = 0 Then isTitle = 1
        .Range(Cells(mRow, 2), Cells(mRow + UBound(arrList, 1) - 1, 1 + UBound(arrList, 2))) = arrList
        .Range(Cells(mRow, 1), Cells(mRow + UBound(arrList, 1) - 1, 1)) = wsSearch.Name
        mRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        Application.DisplayAlerts = True
    End If
    Next wsSearch
    .Range("A1") = "シート名"
End With

End Sub

Function getArr2D(shName As String, shOffset As Long) As Variant
'--------------------------------
' findMe: 対象シートのデータを二次元配列で返す
' name: テラ｜RPA×静かな退職
' instagram: @tera.praer
'--------------------------------
' in1: shName｜データがあるシートの名前
' in2: shOffset｜削除範囲を行数で指定
'--------------------------------

Dim tera As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(shName)
With ws.Range("A1").CurrentRegion
    tera = .Offset(shOffset).Resize(.Rows.Count - shOffset)
End With
getArr2D = tera
End Function

Sub ClearSh(shName As String)
'--------------------------------
' findMe: 対象シートを削除する
' name: テラ｜RPA×静かな退職
' instagram: @tera.rpaer
'--------------------------------
' in1: shName｜削除するシートの名前
'--------------------------------

Dim ws As Worksheet
For Each ws In Worksheets
    If ws.Name Like shName Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next ws

End Sub


Function AddSh(shName As String) As Worksheet
'--------------------------------
' findMe: 対象シートを作成する
' name: テラ｜RPA×静かな退職
' instagram: @tera.rpaer
'--------------------------------
' in1: shName｜追加するシートの名前
'--------------------------------
' out: Worksheet｜追加したシート
'--------------------------------
ClearSh (shName)
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Name = shName
Set AddSh = ws

End Function

'-------------------------------------------
' □□□□□□□□□□□□□　@tera.rpaer
' □□■■■□□□■■■□□　テラ｜RPA×静かな退職
' □■□□□■□■□□□■□　1万人企業の社内SEで自動化オタク
' □■□□□■■■□□□■□　業務自動化ツールのアイデアを発信
' □■□□□■□■□□□■□　ソースコードはキャプションにて
' □□■■■□□□■■■□□　一児のパパ｜可愛い嫁｜オタク
' □□□□□□□□□□□□□　お問合せはDM・コメントでどうそ
'-------------------------------------------

---

このアカウントでは、
 Excel VBA やRPAツールを使用した
パソコン業務の時短術・自動化術を紹介します。

この投稿が、
ま〜ま〜ええやん。と思っていただけましたら
ぜひ、｢いいね｣｢フォロー｣してもらえると励みになります：）

投稿内容に質問・指摘などありましたら、
お気軽にDM・コメントでどうぞ！！

Follow me ! ▷ @tera.rpaer

---