はじめに

データを扱う際に、指定した列の項目を分類し、分類した項目別のシートを作成したいということがあると思う。
色々と方法はあると思うが、Dictionaryオブジェクトで重複のない指定した列の項目リストを作成し、オートフィルターを使って各項目を抽出、新規シートを作成し、コピペするのが一般的な方法ではないかと思う。
だが、もう少し処理をまとめられる方法として、スライサーとAdvancedFilterメソッドを使う方法を思いついたので、記事にしたいと思う。

作成の経緯

たまたま、下記URLで重複のないリストの様々な作成方法を眺めていたところ、Dictionary以外に、ピボットテーブルがあるなら、スライサーを使うのもアリではと考えた。

また、最近、AdvancedFilterメソッドというものを知ったので、使ってみたいと考え、データを分類し、項目別にシートを作成するマクロを作成してみた。

作成したマクロの概要

上述の通り、スライサーとAdvancedFilterメソッドを使用した方法となる。

スライサーとは、以下のURLにある通り、テーブルまたはピボットテーブルをフィルター処理するためにクリックできるボタンのようなものである。

作成したマクロでは、スライサーキャッシュ(SlicerCache)を作成して、重複しない項目リストを作成する。
スライサーキャッシュとは、以下URLによれば、スライサーの現在のフィルター状態と、スライサーが接続されているオブジェクトに関する情報を表すとある。
Excelに表示する各スライサーコントロールは、SlicerCache オブジェクトが関連付けられている Slicer オブジェクトによって表されるため、スライサーキャッシュのみを作成した場合、情報のみが作成され、Excel上にはなにも表示されないようだ。そのため、スライサーキャッシュを作成するだけで、重複しない項目のリストを作成でき、作業セルを使ったり、データを1件ずつ確認する必要もない。
その他、利点なのか分からないが、スライサーの項目は昇順になるため、作成したマクロでは、項目別シートは項目名の昇順で作成される。

また、AdvancedFilterメソッドとは、以下のURLの通り、フィルターの「詳細設定」の「フィルターオプションの設定」ダイアログボックスを使って、フィルターを適用する方法である。

AdvancedFilterメソッドであれば、抽出したデータの出力先を指定できるため、抽出とコピペをまとめてできる。
さらに、AdvancedFilterメソッドには、「重複するレコードは無視する」という設定があるため、別途、データの重複削除の処理を追加することなく、抽出するデータのうち、重複しているデータを除外することができる。

動作手順

表の開始セルを設定
表の範囲を取得
分類したい項目の列番号を指定
不要なシートを削除
表がテーブルではない場合、表の範囲をテーブルに変換
AdvancedFilterメソッド用の条件欄を作成し、セルをアクティブにする
SlicerCacheを作成
SlicerCacheのSlicerItemsの値をAdvancedFilterメソッドを使って抽出
8-1. 条件欄に条件を入力（完全一致とするため、「 "'="」を頭につける）
8-2. AdvancedFilterメソッド用の条件を設定
8-3. 新規シートを作成し、AdvancedFilterメソッドを使って抽出・新規シートへ出力
8-4. 新規シートの列幅を調整、シート名を項目名に変更
作成したSlicerCache、条件欄を削除
表の範囲をテーブルに変換した場合、テーブルを範囲に戻す

注意事項

AdvancedFilterメソッドを実行する際に、表の範囲内にアクティブセルがあると、なぜか失敗するため、とりあえず、条件欄を作成する際に、条件欄のセルをアクティブにする処理を入れている。

完成したマクロ

前提として、以下の図の通り、シートの名称は「データ」、表はA1セルから始まっており、1行目を見出しとする。
列番号「3」のC列「商品名」のデータを分類し、項目別にシートを作成する。

【サンプルデータ】

結果として、以下の図のように「お風呂用洗剤」、「キッチンペーパー」、「キッチン用洗剤」、「トイレットペーパー」の項目別シートが出来上がる。

【実行結果】

【「お風呂用洗剤」シート】

DataClassification

Public Sub DataClassification()

Dim StartRange As Range
Dim TableRange As Range
Dim TargetColumn As Long
Dim mySheet As Worksheet
Dim TableMakeFlag As Boolean
Dim mySlicerCache As SlicerCache
Dim myCriteria As Range
Dim OutRange As Range
Dim OutSheet As Worksheet
Dim i As Long

    Application.ScreenUpdating = False

    With ThisWorkbook.Sheets("データ")
  
         Set StartRange = .Range("A1")
         Set TableRange = .Range(StartRange, StartRange.End(xlDown).End(xlToRight))

        '分類したい項目の列番号を指定
        TargetColumn = 3

        For Each mySheet In ThisWorkbook.Worksheets
            Application.DisplayAlerts = False
            If mySheet.Name <> .Name Then mySheet.Delete
            Application.DisplayAlerts = True
        Next mySheet
        
        If StartRange.ListObject Is Nothing Then
            .ListObjects.Add(xlSrcRange, TableRange, , xlYes).TableStyle = ""
             TableMakeFlag = True
        End If
        
        '条件欄作成
        .Cells(1, .Cells.SpecialCells(xlLastCell).Column + 2).Value = .Cells(StartRange.Row, TargetColumn).Value
        .Cells(1, .Cells.SpecialCells(xlLastCell).Column + 2).Activate
        
        Set mySlicerCache = ThisWorkbook.SlicerCaches.Add(StartRange.ListObject, .Cells(StartRange.Row, TargetColumn).Value)
        
        For i = 1 To mySlicerCache.SlicerItems.Count
        
            '条件入力
            .Cells(1, Columns.Count).End(xlToLeft).Offset(1, 0).Value = "'=" & mySlicerCache.SlicerItems(i).Value
            
            Set OutSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            Set myCriteria = .Cells(1, Columns.Count).End(xlToLeft).CurrentRegion
            Set OutRange = OutSheet.Cells(StartRange.Row, StartRange.Column).Resize(1, TableRange.Columns.Count) '出力範囲
            
            TableRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=myCriteria, CopyToRange:=OutRange, Unique:=True
            OutSheet.Cells.EntireColumn.AutoFit
            OutSheet.Name = mySlicerCache.SlicerItems(i).Value
            
        Next i

        mySlicerCache.Delete
        myCriteria.CurrentRegion.Clear
        If TableMakeFlag Then StartRange.ListObject.Unlist
        .Activate
        
    End With
    
    MsgBox "完了しました"
    
    Application.ScreenUpdating = True
 
End Sub

追記：スライサーのみを使った方法

AdvancedFilterメソッドを使いたいという手段ありきのマクロだったので、上記のようなマクロとなったが、目的をよくよく考えてみたら、スライサーのみで完結するよなと思ったので、スライサーのみを使った方法を追記する。
スライサーがExcel上に表示されていなくても、スライサーキャッシュのみで、問題なく動作した。

動作手順

表の開始セルを設定
表の範囲を取得
分類したい項目の列番号を指定
不要なシートを削除
表がテーブルではない場合、表の範囲をテーブルに変換
SlicerCacheを作成
SlicerCacheのSlicerItemsの各Itemをそれぞれ選択して処理
7-1. SlicerCacheのフィルターを解除
7-2. 選択したい項目以外のSlicerItemのSelectedプロパティをFalseにする
7-3. 新規シートを作成し、スライサーの選択による抽出結果をコピーして出力
7-4. 新規シートの列幅を調整、シート名を項目名に変更
作成したSlicerCacheを削除
表の範囲をテーブルに変換した場合、テーブルを範囲に戻す

注意事項

スライサーの選択による抽出結果をコピーする際に、アクティブセルの位置によっては非表示セルも含めてコピーされてしまうため、SpecialCells メソッドを使って可視セルのみに指定してからコピーしている。下記URLで、バグとして紹介されていた。

DataClassification_Slicer


Public Sub DataClassification_Slicer()

Dim StartRange As Range
Dim TableRange As Range
Dim TargetColumn As Long
Dim mySheet As Worksheet
Dim TableMakeFlag As Boolean
Dim mySlicerCache As SlicerCache
Dim TargetItem As SlicerItem
Dim OutSheet As Worksheet
Dim i As Long

    Application.ScreenUpdating = False

    With ThisWorkbook.Sheets("データ")
        
        Set StartRange = .Range("A1")
        Set TableRange = .Range(StartRange, StartRange.End(xlDown).End(xlToRight))
        
        '分類したい項目の列番号を指定
        TargetColumn = 3

        For Each mySheet In ThisWorkbook.Worksheets
            Application.DisplayAlerts = False
            If mySheet.Name <> .Name Then mySheet.Delete
            Application.DisplayAlerts = True
        Next mySheet
        
        If StartRange.ListObject Is Nothing Then
            .ListObjects.Add(xlSrcRange, TableRange, , xlYes).TableStyle = ""
             TableMakeFlag = True
        End If
           
        Set mySlicerCache = ThisWorkbook.SlicerCaches.Add(StartRange.ListObject, .Cells(StartRange.Row, TargetColumn).Value)
        
        For Each TargetItem In mySlicerCache.SlicerItems
            
            'スライサー項目選択（選択したい項目以外の選択を外す）
            mySlicerCache.ClearManualFilter
            For i = 1 To mySlicerCache.SlicerItems.Count
                If mySlicerCache.SlicerItems(i).Value <> TargetItem.Value Then mySlicerCache.SlicerItems(i).Selected = False
            Next i
            
            Set OutSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            TableRange.SpecialCells(xlCellTypeVisible).Copy OutSheet.Cells(StartRange.Row, StartRange.Column)
            OutSheet.Cells.EntireColumn.AutoFit
            OutSheet.Name = TargetItem.Value
            
        Next TargetItem

        mySlicerCache.Delete
       
        If TableMakeFlag Then StartRange.ListObject.Unlist
        .Activate
        
    End With
    
    MsgBox "完了しました"
    
    Application.ScreenUpdating = True
 
End Sub

サンプルファイル保存先：

更新履歴

2025/05/13：新規投稿
2025/05/14：スライサーのみを使った方法を追加