はじめに
データを扱う際に、指定した列の項目を分類し、分類した項目別のシートを作成したいということがあると思う。
色々と方法はあると思うが、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列「商品名」のデータを分類し、項目別にシートを作成する。
【サンプルデータ】
結果として、以下の図のように「お風呂用洗剤」、「キッチンペーパー」、「キッチン用洗剤」、「トイレットペーパー」の項目別シートが出来上がる。
【実行結果】
【「お風呂用洗剤」シート】
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で、バグとして紹介されていた。
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：スライサーのみを使った方法を追加