複数の文字の色でフィルタリングを行う
エクセルのオートフィルターは文字の色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルのフォント色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。
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.で赤・青・黄の文字色を取得済み）
フィルタリング解除は、標準機能で行を再表示しています。
プログラムの説明
◇コード１
- 選択されたセルからFont.Colorで文字色の値を取得し、末尾に改行を付け足して変数に代入する
- 選択されたすべてのセルに対して、上記を繰り返す
- 最後に処理したセルの改行が邪魔なので取り除く
- 変数の内容をクリップボードに転送する
◇コード２
- クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
- 現在選択している範囲の列番号を取得する
- For Nextの始まりの値を選択範囲の上端の行、終わりの値を下端の行をする
- まずは上端の行から、配列内のデータと一致するか否か比較を行う
- 配列内のいずれかのデータと一致していれば、Next yへ飛ぶ（一致したセルが結合セルの場合は、結合セルを抜けるまで行を進める）
- 配列内のデータすべてと一致しなかった場合は、その行をUnionメソッドで記憶しておく
- 下端の行まで、For ～Nextの繰り返し
- 最後に、検索に一致しなかった行をまとめて非表示にする
- また、下のように複数の文字色が混在するセルは、Font.Colorの値がNullとなるため検索の対象外とし、すべて非表示にする。
空白のセルはFont.Colorの値が黒の文字色と同じになるので、これも検索の対象外とし、すべて非表示にする。
課題
