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

エクセルのオートフィルターは文字の色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルのフォント色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。
VBAならと思ったのですが、用意されているメソッドや関数ではできないみたいです。（たぶん）

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

コード１

Sub 文字色の値を改行区切りでクリップボードに格納()
    '格納する値はリトルエンディアンです
    '複数の文字色が混在するセルはNullとなります
    
    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.Font.Color & vbCrLf
            End If
        Next myRange
        
        V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字）
        
    Else
        V = ActiveCell.Font.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
        
            If Not IsNull(Cells(y, x).Font.Color) And Not Cells(y, x).Value = "" Then '複数の文字色が混在するセル（Null）と空白のセル（黒と値が重複）は、検索の対象外
                Do While i <= UBound(V)
                    If CStr(Cells(y, x).Font.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
            End If
            
            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.で赤・青・黄の文字色を取得済み）

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

 

プログラムの説明
◇コード１

• 選択されたセルからFont.Colorで文字色の値を取得し、末尾に改行を付け足して変数に代入する
• 選択されたすべてのセルに対して、上記を繰り返す
• 最後に処理したセルの改行が邪魔なので取り除く
• 変数の内容をクリップボードに転送する

 

◇コード２

• クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
• 現在選択している範囲の列番号を取得する
• For Nextの始まりの値を選択範囲の上端の行、終わりの値を下端の行をする
• まずは上端の行から、配列内のデータと一致するか否か比較を行う
• 配列内のいずれかのデータと一致していれば、Next yへ飛ぶ（一致したセルが結合セルの場合は、結合セルを抜けるまで行を進める）
• 配列内のデータすべてと一致しなかった場合は、その行をUnionメソッドで記憶しておく
• 下端の行まで、For ～Nextの繰り返し
• 最後に、検索に一致しなかった行をまとめて非表示にする
• また、下のように複数の文字色が混在するセルは、Font.Colorの値がNullとなるため検索の対象外とし、すべて非表示にする。

  

  空白のセルはFont.Colorの値が黒の文字色と同じになるので、これも検索の対象外とし、すべて非表示にする。

 

課題

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