ExcelVBAのフィルタによる文字と背景色の複数条件検索

Question

いつもterateilにてお世話になっております。
今回もVBA関連の質問をさせていただきます。よろしくお願いします。

作ろうとしているもの

ExcelでSheet1にある一覧表から、項目を検索して氏名の列をSheet2に貼り付けるVBAを作っています（以下の画像はSheet1）

氏名の列より右の「性別」「出身地」「居住地」「血液型」を、Sheet2のA1セルに入力した文字を項目名として検索され、A2セルに入力された文字（=val）を検索語句として検索するようにしています。
フィルタにかけた後、抽出された項目の氏名をコピーして別シートに貼り付けるものです。

ws01 = Sheet1 '一覧があるシート
ws02 = Sheet2 '書き出し先のシート

col_num = Worksheets(ws02).Range("A1")
val = Worksheets(ws02).Range("A2")

Worksheets(ws01).Range("A1").AutoFilter Field:=col_num, Criteria1:=val

ここから本題です…

VBAのフィルタに関する質問です。

画像にもあるように、黄色の背景色があるところは要注意項目のため、背景色があるセルをフィルタから除外したり、背景色がある項目だけ検索したいときがあります。
例えば「東京の背景色があるところ」と検索したいのです。

そこで、Criteria2にも追加して検索しようとしました（以下のプログラム）

Worksheets(ws01).Range("A1").AutoFilter Field:=col_num, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor, Criteria2:=val

しかし、黄色の背景色がある項目が全部抽出され、対象以外も出てきてしまって困っています。

色々と調べては見たものの、いまいちどうやればいいのかピンと来ていません。
文字と背景色を検索条件として共存させれば良いのか、ご教授ください。

また、難しいのであれば、どのように回避すべきかを教えていただければ大変助かります。
厚かましいと思いますが、よろしくお願いします。

使用環境 : Excel2013

Answer 1

一度に出来ても、できなくても、
結果として自動実行させるのだから、
各条件で、順次絞り込めばいいだけでは？

その時に、「必要な物を抜き出す」という考えではなく、
逆に、
「不要なものをはじき出す（削除する）」と考えると、
作業手順が簡単になります。

今回の件の場合、
1）フィルターオプション機能で、東京を別のシートに抜き出す。
2）抜き出したデータからオートフィルターで黄色以外のセルを抽出し削除する
という手順で、順次ふるいにかけて行けば、欲しい結果が得られると思います。
その作業手順を自動化すればいいかと思います。

その時に、ユーザーにどのように入力＆操作してもらうかと、
結果をどのように表示するかの画面設計も気になるところですが、
その作業の途中経過は見えないように出来るので、どのようにしても、
ユーザーは気にしないと思います。
処理速度が遅い場合は不満が出てくると思いますが、
高速化はとりあえずおいておいて、
まずは、ご自分の知識の範囲内で結果が出るように、
アプリを完成させてみてください。

Comments

[k_shin]

回答ありがとうございます。今後の参考にさせていただきます。
ありがとうございました。

Answer 2

前の方が仰っているように、通常のAutoFilterではできず、作業列を使うのがベストだと思うのですが、今回試しに、絞り込む内容の入った配列を作り、Operator:=xlFilterValuesでその配列をもとにフィルターするコードを書いてみたので参考になればと思います。

Sub filter()
Dim Val As String
Dim col_num, i As Integer
Dim Arr() As String: ReDim Arr(0) '空の配列を作成
col_num = Range("B11").Value 'セルB11をcol_numに代入
Val = Range("C11") 'セルC11をVal(フィルターするキーワード)に代入
For i = 2 To Cells(2, col_num).End(xlDown).Row '表の最下行までループ
    If Cells(i, col_num).Interior.Color = RGB(255, 255, 0) And Cells(i, col_num) = Val Then
    '「背景色が黄色」かつ「内容がValと一致」した場合の処理
        ReDim Preserve Arr(UBound(Arr) + 1) '配列を一つ増やす
        Arr(UBound(Arr)) = Cells(i, 1) '条件に合致する行の一列目の内容(氏名)を配列に追加
    End If
Next i
Range("A1").AutoFilter Field:=1, Criteria1:=Arr, Operator:=xlFilterValues
    '配列Arrに含まれる行のみをフィルター
End Sub

Comments

[hatena19]

配列でフィルターをかけるというのはいいアイデアだと思います。
「抽出された項目の氏名をコピーして別シートに貼り付ける」というのが最終目的のようですので、
だとしたら、その配列を直接、出力先に代入してもいいかなと思いました。

[k_shin]

返信が遅くなってすいません。出張に行ってまして、遅れてしまいました。
ベストアンサーを配列でやってくださったhatena19さんにするか、どちらにするか迷いましたが、元々フィルターベースで作っていましたので、こちらの方の回答をベストアンサーにしました。
無事にフィルターを掛けることに成功しました。ありがとうございました。

Answer 3

AutoFilterだけの機能では無理だと思います。

作業列を使う方法がよく使われます。

Office TANAKA - Excel VBA Tips［オートフィルタ［作業列で絞り込む］］

複雑な条件（複数除外等）のオートフィルター（AutoFilter）｜VBA技術解説

追記

フィルタにかけた後、抽出された項目の氏名をコピーして別シートに貼り付けるものです。

フィルターは手段で最終目的が該当する氏名のコピーなら、
オートフィルターは使わずに、
VBAで該当する氏名を配列に格納して、
それを出力先に代入すればシンプルになるでしょう。

コード例

Sub NameCopy()
    Dim ws01 As Worksheet: Set ws01 = Sheet1
    Dim ws02 As Worksheet: Set ws02 = Sheet2
    Dim col_Num As Long:   col_Num = ws02.Range("A1")
    Dim val As String:     val = ws02.Range("A2")
    Dim maxRow As Long:    maxRow = ws01.Cells(1, 1).End(xlDown).Row
    '該当する名前の格納用配列（最大数分確保しておく）
    Dim aryName() As String: ReDim aryName(maxRow - 2)
    
    Dim i As Long, cnt As Long
    For i = 2 To maxRow
        With ws01.Cells(i, col_Num)
            If .Interior.Color = vbYellow And .Value = val Then
                aryName(cnt) = ws01.Cells(i, 1)
                cnt = cnt + 1
            End If
        End With
    Next
    ws02.Range("B:B").ClearContents
    '名前配列を縦横変換して代入、代入するセル範囲のサイズを該当件数で制限しておく
    ws02.Range("B1").Resize(cnt).Value = WorksheetFunction.Transpose(aryName)
End Sub

Comments

[k_shin]

回答ありがとうございます。
追記でコードを書いてくださり、ありがとうございます。今後の参考にさせていただきます。
ありがとうございました。