Excel VBA 特定文字列を含む行を抽出し文字列部分に書式設定を行う

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

例として、以下のような食事記録の表があるとする。
【食事記録】
![画像1.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/f0c98a73-8705-44f8-a1db-3fcde8adc5aa.jpeg)


以下の図のように、どの時間帯でもいいので、「納豆」もしくは「キムチ」を食べた日だけ抽出したい。
【抽出結果】
![画像2.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/371e69ea-d3d7-4f96-80c9-150bc6607bb8.jpeg)

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

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

https://vbae.odyssey-com.co.jp/column6/s62101.html

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

### 動作手順
1. 空白で区切って入力されている検索したい文字列をSplit関数で配列として取得
1. 表を初期化（非表示行を表示、塗りつぶし、文字色、太字を解除）　
1. 行ごとに検索したい文字列の全角・半角について、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関数による検索の考え方は、以下の通りとなる。

![スクリーンショット 2025-05-19 151205.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/fd1bc196-2a44-4c0b-9493-d7e115792aef.png)

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

![スクリーンショット 2025-05-19 152729.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/947e11c6-e233-4398-8e62-a81597349f6a.jpeg)

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

![スクリーンショット 2025-05-19 153133.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/763a6ed0-52a0-47b8-8e54-16410ce5d749.jpeg)

上記の考え方で、該当セルを黄色に塗りつぶすコードは以下のとおりである。
```VB: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 オブジェクトの文字数を指定


https://learn.microsoft.com/ja-jp/office/vba/api/excel.range.characters

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

https://learn.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/instr-function

以下の文章の「トースト」を探して書式設定を行う場合、作成したマクロ内におけるCharactersオブジェクトの取得とInStr関数による検索の考え方は、以下の通りとなる。
![スクリーンショット 2025-05-19 155748.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/09a7086c-7bbe-4754-b374-4d9010e50fea.png)

① 開始位置を指定するFindStart変数を1にして、InStr関数を使って文字列の開始位置「4」を割り出し、CharactersプロパティのStartに設定
② Len関数を使って文字列の文字数「4」を取得し、CharactersプロパティのLengthに設定
③ 取得したCharactersオブジェクト（4文字目からの4文字）に対して、書式設定を行う
![画像11.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/43b070a2-c37c-484c-912f-5f076abd779c.jpeg)

④ FindStart変数を見つかった位置の後ろからとするため、見つかった位置「4」+文字数分「4」の値「8」をFindStart変数に代入し、InStr関数の開始位置とする
![画像1.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/8a4f6463-c91f-4538-a424-13a5ea6e7f10.png)


⑤ 次の検索開始位置「8」文字目からInStr関数を使って検索すると「12」となる
　（InStr関数は開始位置をずらしても、戻り値は先頭からの文字の位置を返す）
![画像1.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/361e9842-4ea6-40a9-a746-a38d45202d66.jpeg)


⑥上記の処理をInStr関数が0になる（見つからなくなる）まで繰り返す
![スクリーンショット 2025-05-19 172216.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/d770ebc4-df32-4403-a0c5-4ffdbf23253c.png)

上記の考え方で、該当文字列を赤の太字にするコードは以下のとおりである。
```VB: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セルにドロップリストで選択できるようにしてある。
![スクリーンショット 2025-05-19 141155.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/05a0f298-aa1a-4f3e-8fef-a59ce3992619.png)

```VB: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

```

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

https://github.com/rie1234k/ExcelVBA_Tips/tree/main/ExtractAnyColumnLikeValues