三つ以上の部分一致条件で絞り込みを行う（オートフィルター不使用）

オートフィルターを使った絞り込みでは、引数に配列を指定しても、三つ以上の部分一致条件での絞り込みができませんでした。なので、オートフィルターを使わずに三つ以上の部分一致条件で絞り込みをさせてみたいと思います。まあ、検索に一致しない行を非表示にするだけなんですけどね。

目次

検索に使用したいキーワードの取り込み

まず、下記のマクロを使用して、部分一致条件に使用したいキーワードをクリップボードに取り込んで見ましょう。

Sub 文字列の両端にワイルドカードを付加してクリップボードに転送()
    Dim myRange As Range
    Dim V As String
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する

    For Each myRange In Selection.SpecialCells(xlCellTypeVisible)   '可視セルのみに処理を行う
        If myRange.Address = myRange.MergeArea(1).Address Then   '結合セルの場合は左上の値のみ取り出す
            V = V & "*" & myRange.Value & "*" & vbCrLf
        End If
    Next myRange
    
    V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字）
    
    myLib.SetText V  '変数の値をDataObjectに格納する
    myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する

End Sub

同一Sheet、別Sheet、別Bookのどこでもいいので、検索条件にしたい文字列の入ったセルを選択（複数可）した状態でマクロを実行します。画像では、同一Sheet内から「めぐすり」、「ポーション」、「ギサールのやさい」をクリップボードに取り込んでいます。

クリップボードには、こんな感じでデータが取り込まれます（自動的にワイルドカードが付加されます）。文字列の両端にワイルドカードが付加されるのが気に入らなければ、クリップボード内のデータをいじっても結構です。

取り込んだキーワードを使って部分一致条件で絞り込み

次に、絞込みを行いたい列のセルを選択（画像であれば、A列の表内のどこか）した状態で、下記のマクロを実行します。

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 = ActiveCell.Column
        
        For Y = ActiveCell.CurrentRegion.Row + 1 To ActiveCell.CurrentRegion. _
        Rows(ActiveCell.CurrentRegion.Rows.Count).Row
            i = 0
        
            Do While i <= UBound(V)
                If Cells(Y, X).Value Like 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

これで、クリップボード内を参照し、「めぐすり」、「ポーション」、「ギサールのやさい」の文字列が含まれるOR条件で絞り込みが行われました。

オートフィルターを使用していないので、絞り込みを解除したい場合は、行を再表示して下さい。

説明しなければ、誰にも気づかれなさそうですが、結合セルの二行目以降が折りたたまれないように配慮しています。（オートフィルターを使った文字列の絞り込みでは、結合セルの二行目以降は折りたたまれてしまいます）

オートフィルターでの絞り込みはこんな感じ。B､C､D列の該当するデータが隠れてしまっています。

ざっくりとコードの説明

Sub 文字列の両端にワイルドカードを付加してクリップボードに転送()

1. 選択されたセルから文字列を取り出し、文字列の両端にアスタリスク、末尾に改行を付け足して変数に代入する
2. 選択されたすべてのセルに対して、上記を繰り返す
3. 最後に処理したセルの改行が邪魔なので取り除く
4. 変数の値をクリップボードに転送する

Sub 三つ以上の部分一致条件で絞込みを行う()

1. クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
2. 現在選択しているセルの列番号を取得する
3. For Nextの始まりの値をCurrentRegionの上端の行、終わりの値を下端の行をする（+1で、見出し行を除く）
4. まずは見出しの下の行から、配列内のデータと一致するか否か比較を行う
5. 配列内のいずれかのデータと一致していれば、何もせずに次のNextへ飛ぶ（一致したセルが結合セルの場合は、結合セルを抜けるまで行を進める）
6. 配列内のデータすべてと一致しなかった場合は、その行を記憶しておく
7. 下端の行まで、4～6の繰り返し
8. 最後に、検索に一致しなかった行をまとめて非表示にする

コードをざっくりと組んだ時点では、ループの中で検索に一致しない行を見つけるたびに非表示にさせていました。･･････が、これをやると途中で眠くなってしまうほど処理に時間がかかってしまうので、検索に一致しない行をUnionメソッドで順次取得し（Ctrlキーを押しながら連続していない行を選択していくようなもの）、最後にまとめて非表示にするという形にしました。

改善の余地

見出しが結合セルだった場合の処理を追加しておいてもいいかも。