はじめに

データを抽出する条件として、いずれかの列に複数の特定の文字列のいずれか1つ以上を含むセルがある行を抽出したいとする。このような場合、抽出するには作業セルを使用する等、おそらく一筋縄ではいかないと思う。

例として、以下のような食事記録の表があるとする。
【食事記録】

以下の図のように、どの時間帯でもいいので、「納豆」もしくは「キムチ」を食べた日だけ抽出したい。
【抽出結果】

上記のような処理を行うマクロについて少し考えてみたい。

マクロ作成の経緯

「やってみよう!Excel VBAで業務改善!」というコラムを読んでいて、以下のURLで上記のようなマクロを作成する部分があり、自分だったら、どのように作成するか考えたのがきっかけだった。

作成したマクロの概要

試行錯誤した結果、ワークシート関数のCountIf関数とMatch関数を使用し、位置を特定して、処理を行うマクロを作成した。
Findメソッドも検討したが、オプションをすべて指定しないと、場合によってはうまく検索されず、何かと面倒なので、ワークシート関数のCountIf関数とMatch関数を使用する方法に落ち着いた。
Match関数は、大文字・小文字は区別しないため、大文字・小文字については区別なく検索できる。だが、全角・半角については区別されるため、全角・半角どちらでも対応できるように、全角・半角の両方で検索することにした。
また、行を抽出しただけでは、どこに検索した文字列があるのか分かり辛いため、文字列のあるセルを黄色に塗りつぶし、該当する文字列部分を赤の太字にして、目立つようにした。
また、複数の文字列について、OR条件だけではなく、AND条件でも検索できるようにした。

動作手順

空白で区切って入力されている検索したい文字列をSplit関数で配列として取得
表を初期化（非表示行を表示、塗りつぶし、文字色、太字を解除）　
行ごとに検索したい文字列の全角・半角について、Countif関数とMatch関数を使って検索
　3-1. その行に１以上あった場合、検索文字列ごとに、ChackCount変数に１を追加
　3-2. CountIf関数の件数分だけ、Match関数の検索位置を移動させながら検索
　3-3. 見つかったセルを黄色に塗りつぶす　
　3-4.セル内の文字列から検索する文字列をInStr関数を使って検索位置を移動させながら検索
　3-5. 見つかった文字列部分を赤の太字にする
　3-6. OR/ANDの検索条件に合わせ、該当しない行を非表示にする
（OR：ChackCount変数が0、AND:ChackCount変数と検索文字列の数が一致しない場合）

Match関数によるセル検索

例えば、以下のデータ行で、「サラダ」を検索する場合、作成したマクロ内におけるMatch関数による検索の考え方は、以下の通りとなる。

① 1回目の検索はA列からの範囲を対象に検索し、3列目のデータであるC6セルが該当する。

② ２回目は、Match関数の検索範囲をOffsetプロパティを使って、1回目で該当したセルの次のセルであるD6セルが開始位置になるように、1回目の検索で見つかった列の分、検索範囲をずらす。
③ ２回目のMatch関数で該当するセルの位置を表す値は、開始位置であるD列から数えた位置になるため、「1」となる。その値にずらした分の「3」を足して、実際の列番号「4」にする。

上記の考え方で、該当セルを黄色に塗りつぶすコードは以下のとおりである。

Match関数によるセル検索

Public Sub FindWords() 
Dim i As Long
Dim FindColumn As Long
    For i = 1 To WorksheetFunction.CountIf(Range("A6:E6"), "*" & "サラダ" & "*")
        FindColumn = WorksheetFunction.Match("*" & "サラダ" & "*", Range("A6:E6").Offset(0, FindColumn), 0) + FindColumn
        Cells(6, FindColumn).Interior.Color = vbYellow
    Next i
End Sub

CharactersオブジェクトとInSter関数による文字列検索

セル内の文字列を操作する場合は、Range.Charactersプロパティを使用する。
Charactersプロパティはオブジェクトテキスト内の文字範囲を表す Characters オブジェクトを返す。
この Characters オブジェクトを使用して、テキスト文字列内の文字の書式設定ができる。
　
式：Rangeオブジェクト.Characters (Start, Length)
　　Start：Characters オブジェクトの先頭となる文字の位置を指定
　　Length：Characters オブジェクトの文字数を指定

検索する文字列のCharactersオブジェクトの取得にあたって、先頭の文字の位置を指定するには、文字列内で文字列を検索する必要がある。その場合には、InStr関数を使用する。

以下の文章の「トースト」を探して書式設定を行う場合、作成したマクロ内におけるCharactersオブジェクトの取得とInStr関数による検索の考え方は、以下の通りとなる。

① 開始位置を指定するFindStart変数を1にして、InStr関数を使って文字列の開始位置「4」を割り出し、CharactersプロパティのStartに設定
② Len関数を使って文字列の文字数「4」を取得し、CharactersプロパティのLengthに設定
③ 取得したCharactersオブジェクト（4文字目からの4文字）に対して、書式設定を行う

④ FindStart変数を見つかった位置の後ろからとするため、見つかった位置「4」+文字数分「4」の値「8」をFindStart変数に代入し、InStr関数の開始位置とする

⑤ 次の検索開始位置「8」文字目からInStr関数を使って検索すると「12」となる
　（InStr関数は開始位置をずらしても、戻り値は先頭からの文字の位置を返す）

⑥上記の処理をInStr関数が0になる（見つからなくなる）まで繰り返す

上記の考え方で、該当文字列を赤の太字にするコードは以下のとおりである。

Inster関数による文字列検索

Public Sub FindCharacters() 
Dim FindStart As Long
    FindStart = 1
    Do
        With Range("A1").Characters(Start:=InStr(FindStart, Range("A1").Value, "トースト"), Length:=Len("トースト"))
            .Font.Color = vbRed
            .Font.Bold = True
        End With
        FindStart = InStr(FindStart, Range("A1").Value, "トースト") + Len("トースト")
    Loop Until InStr(FindStart, Range("A1").Value, "トースト") = 0
End Sub

完成したマクロ

前提として、以下の画像のようなシートを想定している。
シート名は「食事記録」、表は4行目以降からで、B1セルに検索文字列を空白を区切りとして複数入力できる。検索において、大文字・小文字、全角・半角は区別しない。
検索条件のORとANDは、B2セルにドロップリストで選択できるようにしてある。

ExtractAnyColumnLikeValues

Public Sub ExtractAnyColumnLikeValues()

Dim FindWords As Variant
Dim TargetWords(1) As String
Dim TableRange As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim iRow As Long
Dim ChackFlag As Boolean
Dim ChackCount As Long
Dim FindColumn As Long
Dim TargetRange As Range
Dim FindRange As Range
Dim FindStart As Long

    Application.ScreenUpdating = False

    With ThisWorkbook.Sheets("食事記録")
        FindWords = Split(.Range("B1").Value, " ", , vbTextCompare)
        .Rows.Hidden = False
        
        With .Range("A4") '表の開始セル
            iRow = .Row + 1
            Set TableRange = .CurrentRegion
            With TableRange
                .Offset(1).Interior.ColorIndex = xlNone
                .Offset(1).Font.ColorIndex = xlAutomatic
                .Offset(1).Font.Bold = False
             End With
        End With
        
        Do
            ChackCount = 0
            Set TargetRange = Intersect(.Rows(iRow), TableRange)
            
            For i = 0 To UBound(FindWords)
                TargetWords(0) = StrConv(FindWords(i), vbWide)
                TargetWords(1) = StrConv(FindWords(i), vbNarrow)
                ChackFlag = False
                For j = 0 To 1
                    If WorksheetFunction.CountIf(TargetRange, "*" & TargetWords(j) & "*") > 0 Then
                        If ChackFlag = False Then
                            ChackCount = ChackCount + 1
                            ChackFlag = True
                        End If
                        FindColumn = 0
                        For k = 1 To WorksheetFunction.CountIf(TargetRange, "*" & TargetWords(j) & "*")
                            FindColumn = WorksheetFunction.Match("*" & TargetWords(j) & "*", TargetRange.Offset(0, FindColumn), 0) + FindColumn
                            Set FindRange = .Cells(iRow, FindColumn)
                            FindRange.Interior.Color = vbYellow
                            FindStart = 1
                            Do
                                With FindRange.Characters(Start:=InStr(FindStart, FindRange.Value, TargetWords(j), vbTextCompare), Length:=Len(TargetWords(j)))
                                    .Font.Color = vbRed
                                    .Font.Bold = True
                                End With
                                FindStart = InStr(FindStart, FindRange.Value, TargetWords(j), vbTextCompare) + Len(TargetWords(j))
                            Loop Until InStr(FindStart, FindRange.Value, TargetWords(j), vbTextCompare) = 0
                        Next k
                    End If
                Next j
            Next i
            
            Select Case .Range("B2").Value
                Case "OR"
                    If ChackCount = 0 Then .Cells(iRow, "F").EntireRow.Hidden = True
                Case "AND"
                    If ChackCount <> UBound(FindWords) + 1 Then .Cells(iRow, "F").EntireRow.Hidden = True     
            End Select
            
            iRow = iRow + 1
        
        Loop Until .Cells(iRow, "A").Value = ""
    End With
    
    Application.ScreenUpdating = True

End Sub

サンプルファイル保存先：