はじめに
データを抽出する条件として、いずれかの列に複数の特定の文字列のいずれか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」にする。
上記の考え方で、該当セルを黄色に塗りつぶすコードは以下のとおりである。
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になる（見つからなくなる）まで繰り返す
上記の考え方で、該当文字列を赤の太字にするコードは以下のとおりである。
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セルにドロップリストで選択できるようにしてある。
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
サンプルファイル保存先：