編集

【ExcelVBA】１つの表データを項目ごとにシートを分ける

2025/06/09 ｜2025/09/12

今回は、１つの表から項目ごとにシートに分けるデータ分割処理をご紹介します。業務上では、フィルター抽出→抽出したデータを貼り付けという動作はよくあることです。今回も特に難しい処理ではありません。

ここで紹介するマクロの動作としては、手作業でやる時と同様な処理です。①まず新しいシートを用意し、②フィルター抽出で特定のデータを表示し、③表示されたデータをコピーして新しいシートに貼り付ける、と言った流れになります。

また、引き続き前回作成したマクロファイルに後付けして作っています。

▼過去記事：複数シートの内容を１シートにまとめる

【ExcelVBA】複数シートの内容を１シートにまとめる | ともゆきの独り言（雑記ブログ）

画面設計

設置場所別出力ボタン：「MainProcess3」を指定

設置場所別出力ボタンだけ追加しました。その他のボタンなどは前回のままですが、今回は使用しません。

入力データ

前回の複数CSVファイルを取り込んだ状態から始めます。

処理実行結果

設置場所別出力ボタンを押すと、新たに設置場所ごとのシートが作成されます。

ソースコード（ExcelVBA）

Option Explicit
Sub MainProcess3()

    Dim AllWS As Worksheet
    Set AllWS = Worksheets("集約")

    '新しいシートの作成
    Dim ListWS As Worksheet
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "設置場所"
    Set ListWS = ActiveSheet
    
    '設置場所シートの重複削除と配列格納
    Dim Arr As Variant
    ListWS.Range("A:A").Value = AllWS.Range("F:F").Value
    ListWS.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Arr = ListWS.Range("A2:A" & ListWS.Cells(ListWS.Rows.Count, "A").End(xlUp).Row)

    '設置場所別シート出力
    Dim item As Variant
    For Each item In Arr
        Dim PlaceWS As Worksheet
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = item
        Set PlaceWS = ActiveSheet
        AllWS.Range("A1").AutoFilter Field:=6, Criteria1:=item
        AllWS.Range("A1").CurrentRegion.Copy PlaceWS.Range("A1")
    Next

    'オートフィルターの解除
    AllWS.Range("A1").AutoFilter

End Sub

ポイント

フィルターの抽出項目が設置場所なので、入力データである「集約」シートのF列（設置場所）を新しいシートにコピーし、重複削除で一意の項目を割り出します。タイトル行も含まれますので、Offsetで１行下げた範囲を一旦配列に格納します。後続の繰り返し処理で使用します。
シート出力の繰り返し処理は、For Each～Nextループで、配列の要素を受ける変数「item」はVariant型です。新しいシートを用意し、フィルター抽出し、コピー＆貼り付けです。コピー＆貼り付けの際、セルA1のCurrentRegionで範囲指定していますが、非表示セルはコピーされずに貼り付けることができます（Excel上の仕様です）。より詳細な内容については下記をご参照ください。

▼オートフィルタを使い倒す

オートフィルタを使い倒す
undefined
officetanaka.net

▼絞り込んだ結果をコピーする

絞り込んだ結果をコピーする
undefined
officetanaka.net