複数のセルの色でフィルタリングを行う

前回は複数の文字の色でしたが、今回は複数のセルの色でフィルタリングしてみましょう。内容は一部、前回と重複しますのでご了承ください。

kouten0430.hatenablog.com

エクセルのオートフィルターはセルの色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルの色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。

VBAならと思ったのですが、用意されているメソッドや関数ではできないみたいです。（たぶん）

ということで、複数のセルの色でフィルタリングできるコードを作ってみました。
（今回は二つのコードを使います）

コード１

Sub セル色の値を改行区切りでクリップボードに格納()
    '格納する値はリトルエンディアンです
    
    Dim myRange As Range
    Dim V As String
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    If Selection.Count > 1 Then
        For Each myRange In Selection.SpecialCells(xlCellTypeVisible)   '可視セルのみに処理を行う
            If myRange.Address = myRange.MergeArea(1).Address Then   '結合セルの場合は左上の値のみ取り出す
                V = V & myRange.Interior.Color & vbCrLf
            End If
        Next myRange
        
        V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字）
        
    Else
        V = ActiveCell.Interior.Color
        
    End If
    
    myLib.SetText V  '変数の値をDataObjectに格納する
    myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する

End Sub

コード２

Sub 複数のセルの色で絞込みを行う()
    'クリップボードに格納されたセル色の値を参照し、OR条件で絞込みします
    '実行前に絞り込みを行う列範囲（見出しを除く）を選択しておきます
    'セル色が一致しない行を非表示にします（オートフィルターを使いません）
    Dim V As Variant
    Dim i As Integer
    Dim x As Integer
    Dim y As Long
    Dim Yn As Long
    Dim myRange As Range
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    Application.ScreenUpdating = False  '画面表示の更新をオフにする
    
    myLib.GetFromClipboard
        On Error Resume Next
    V = myLib.GetText
        On Error GoTo 0
        
    If Not IsEmpty(V) Then
        V = Split(CStr(V), vbCrLf)
        x = Selection.Column

        For y = Selection.Row To Selection.Rows(Selection.Rows.Count).Row
            i = 0
        
            Do While i <= UBound(V)
                If CStr(Cells(y, x).Interior.Color) = V(i) Then '配列の内容と一致している場合は行を進める
                        Yn = y + 1
                        Do While Cells(y, x).Address = Cells(Yn, x).MergeArea(1).Address    '結合セルを抜けるまで行を進める
                            Yn = Yn + 1
                        Loop
                        y = Yn - 1
                    
                    GoTo nx
                Else
                    i = i + 1
                End If
            Loop
            
            If myRange Is Nothing Then
                Set myRange = Range(y & ":" & y)    '配列の内容全てと一致しなかった一番最初の行
            Else
                Set myRange = Union(myRange, Range(y & ":" & y))    '配列の内容全てと一致しなかった行
            End If
             
nx:
        Next y
        
        myRange.EntireRow.Hidden = True '検索に一致しなかった行をすべて非表示にする
    Else
        MsgBox "クリップボードにデータがありません！"
    End If

End Sub

※コードの使用方法 SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。

 実行手順

1. まず、フィルターに使用したい色のセルを複数選択した状態で、コード１を実行します。（この処理でセル色の値がクリップボードに一時保存されます）
2. フィルタリングしたい列の範囲を選択し、コード２を実行します。

実行風景（事前に実行手順の1.で赤・青・黄のセル色を取得済み）

フィルタリング解除は、標準機能で行を再表示しています。

プログラムの説明

• 割愛

課題

• 二つのコードを使うので煩雑。
• クリップボードを使う方法は安定しない場合がある。（私の環境だと、クリップボードへのアクセスに数百回に一度失敗するかどうかなので実用上問題なし）
• フィルタリング範囲を手動で選択するのが面倒。※自動で選択させる方法（CurrentRegionを使う方法・シートの最終行からEnd(xlUp)する方法・罫線の有無で判定する方法）もあるけど、表の作り方は人によって千差万別なので確実に自動選択できる保証がない･･････。
• フィルタリングの解除が面倒。