概要
Excelのフィルター条件は各列ごとにポチポチと設定する必要がある。
テーブルに対してはスライサーというものもあるが、これもまたポチポチやってる感は否めない。
フィルター条件を設定する際、目的は値の絞り込みであることが非常に多い。(と思う)
テーブルのデータを眺めているとき、「あ、この値でフィルターしたいな」と思ったとする。
その時のプロセスは「この値」を記憶してヘッダーのフィルタ設定を開き、
データの一覧から「この値」を探し出して選択する。もしくは条件を書いたりする。
今まさに「この値」を目にしているのに回りくどいと思うことが非常に多い。
「この値」はまさにセルの値なので、それを選択してパッとできないか、というところから思いついた。
【追記】
テーブルの右クリックメニューに「選択したセルの値でフィルター」という機能がある、
とコメントで教えていただきました。
こちらの機能は単一セルのみ対象とするような動きでしたので、
本記事のマクロは「複数選択できること」が強み、という方向で住み分けさせていただきます。
仕組み
単一または複数のセルを選択した状態で実行するマクロなので、対象はSelection。
テーブルのセルに限定して実行する。ので、Selectionの各セルがテーブルに含まれるか否かをまず判定する。
あまりないと思うが、複数テーブルにまたがっていた場合は個別に動作する。
次に、各セルがテーブルで言うとこの何列目かを算出し、セルの値でフィルターを有効化する。
つまり、複数セルを「これと、これと、これで」と選択してポチれば一瞬でフィルターできる。
以下の表を見ているとき、所持キャラクターが ケフカorモグ で、分類が 楽器 で絞りたいと思ったら
ケフカ、モグ、楽器 のセルを選択した状態で実行する
これでパッとフィルターしてくれる
中身
【2020/1/25 修正しました】
選択セルの値を取得していた箇所ですが、セルの書式設定がされているとフィルターできないことがあるため
selectionList(3) = trgRange.Value を selectionList(3) = trgRange.Text に変更しました。
Option Explicit
Sub filterBySelection()
If TypeName(Selection) <> "Range" Then Exit Sub
'選択セルを配列にしてCollectionに格納する
Dim selectionList(1 To 3) As String '1:テーブル名, 2:列番, 3:値
Dim selects As Collection: Set selects = New Collection
Dim trgRange As Range
For Each trgRange In Selection
If Not trgRange.ListObject Is Nothing Then
selectionList(1) = trgRange.ListObject.Name
selectionList(2) = SET_TABLECOLUMN(trgRange) 'テーブルの列番に変換する
selectionList(3) = trgRange.Text
selects.Add selectionList
End If
Next
If selects.Count < 1 Then Exit Sub
'対象テーブル名を集計する
Dim tableNames As Collection: Set tableNames = New Collection
Set tableNames = GROUPING_TABLENAME(selects)
'対象テーブルを順番に処理する
Dim tableName As Variant, tb As ListObject
For Each tableName In tableNames
Set tb = ActiveSheet.ListObjects(tableName)
Dim columns As Collection: Set columns = New Collection
Set columns = GROUPING_COLUMN(tb, selects)
'テーブルの列ごとにフィルターを適用する
Dim column As Variant, sel As Variant
For Each column In columns
Dim arr() As String: arr = Split(vbNullString)
For Each sel In selects
If sel(2) = column Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = sel(3)
End If
Next
tb.Range.AutoFilter Field:=column, Criteria1:=arr, Operator:=xlFilterValues
Next
Next
End Sub
Function GROUPING_TABLENAME(col As Collection) As Collection
Dim tableNames As Collection: Set tableNames = New Collection
Dim tmp As Variant
On Error Resume Next
For Each tmp In col
tableNames.Add tmp(1), tmp(1)
Next
On Error GoTo 0
Set GROUPING_TABLENAME = tableNames
End Function
Function SET_TABLECOLUMN(trgRange As Range) As Long
Dim wsCol As Long, tbCol As Long
wsCol = trgRange.column
If trgRange.ListObject.Range.column > 1 Then
tbCol = wsCol - trgRange.ListObject.Range.column + 1
Else
tbCol = wsCol
End If
SET_TABLECOLUMN = tbCol
End Function
Function GROUPING_COLUMN(tb As ListObject, selects As Collection) As Collection
Dim columns As Collection: Set columns = New Collection
Dim tmp As Variant
On Error Resume Next
For Each tmp In selects
columns.Add tmp(2), tmp(2)
Next
On Error GoTo 0
Set GROUPING_COLUMN = columns
End Function
補足
Sub filterBySelection の中で実際にフィルター条件の配列を作成する以下の部分。
For Each sel In selects
If sel(2) = column Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = sel(3)
End If
Next
【2020/1/25 修正しました】
この方法の場合は一つ目の要素が空白になるが、空白はフィルター条件とはならないため問題ない。
すみません、空白は思いっきりフィルター条件になりますね…
要素数0の配列を作っておくことで回避する手段に変更しました。
Dim arr() As String: arr = Split(vbNullString)
また、テーブル名や列番はCollectionに入れることで重複の除去を行っているが、
条件の値については重複していても問題なく動作する。