【ExcelVBA】複数選択セルの値でテーブルをフィルターする

# 概要
Excelのフィルター条件は各列ごとにポチポチと設定する必要がある。
テーブルに対してはスライサーというものもあるが、これもまたポチポチやってる感は否めない。
フィルター条件を設定する際、目的は値の絞り込みであることが非常に多い。(と思う)

テーブルのデータを眺めているとき、「あ、この値でフィルターしたいな」と思ったとする。
その時のプロセスは「この値」を記憶してヘッダーのフィルタ設定を開き、
データの一覧から「この値」を探し出して選択する。もしくは条件を書いたりする。

今まさに「この値」を目にしているのに回りくどいと思うことが非常に多い。
「この値」はまさにセルの値なので、それを選択してパッとできないか、というところから思いついた。

【追記】
テーブルの右クリックメニューに「選択したセルの値でフィルター」という機能がある、
とコメントで教えていただきました。
こちらの機能は単一セルのみ対象とするような動きでしたので、
本記事のマクロは「複数選択できること」が強み、という方向で住み分けさせていただきます。



# 仕組み
単一または複数のセルを選択した状態で実行するマクロなので、対象はSelection。
テーブルのセルに限定して実行する。ので、Selectionの各セルがテーブルに含まれるか否かをまず判定する。
あまりないと思うが、複数テーブルにまたがっていた場合は個別に動作する。
次に、各セルがテーブルで言うとこの何列目かを算出し、セルの値でフィルターを有効化する。
つまり、複数セルを「これと、これと、これで」と選択してポチれば一瞬でフィルターできる。

以下の表を見ているとき、所持キャラクターが `ケフカorモグ` で、分類が `楽器` で絞りたいと思ったら
![01.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/219708/9efb0e48-f185-8b76-4ad2-17ee0b5c25c7.png)

`ケフカ、モグ、楽器` のセルを選択した状態で実行する
![02.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/219708/4ac593e0-6aae-c96f-c198-b33336310944.png)

これでパッとフィルターしてくれる
![03.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/219708/6fab4037-1d69-7ef8-6e2c-9fa31cae5bfe.png)

# 中身
【2020/1/25 修正しました】

選択セルの値を取得していた箇所ですが、セルの書式設定がされているとフィルターできないことがあるため
`selectionList(3) = trgRange.Value` を `selectionList(3) = trgRange.Text` に変更しました。


``` vb
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` の中で実際にフィルター条件の配列を作成する以下の部分。

``` vb
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に入れることで重複の除去を行っているが、
条件の値については重複していても問題なく動作する。