EXCEL VBA あいまいな条件検索・複数条件を検索・該当する文字のみ検索・配列を利用（テクニック）

2023年3月21日

EXCEL VBA あいまいな条件検索・複数条件を検索・該当する文字のみ検索・配列を利用（テクニック）

●はじめに

　今回説明するのは、あいまい検索・部分一致検索をする方法を説明いたします。入力されたキーワードに対して、そのキーワードが含まれるすべての項目を検索します。Excel VBAではVBA関数を組み合わせてあいまい検索を実装することができます。本記事では、Excel VBAでのあいまい検索の実装方法を詳しくサンプルプログラムを交えて順番に説明いたします。

●【EXCEL VBA セルの値を連続的に検索・複数セルを抽出・全ての検索・次の検索・同じ検索条件で検索（FindNextメゾット）については、下記を参照して下さい】

EXCEL VBA セルの値を連続的に検索・複数セルを抽出・全ての検索・次の検索・同じ検索条件で検索（FindNextメゾット）

●【EXCEL VBA セルの検索（完全一致・部分一致・複数一致）「Find・FindNextメゾット」の使い方、下記を参照して下さい】

EXCEL VBA セルの検索（完全一致・部分一致・複数一致）「Find・FindNextメゾット」の使い方

EXCEL VBA あいまい検索　複数のキーワードに対しての検索・行番号と件数取得　（テクニック）

●プログラム説明　(サンプル①)

下記のサンプルプログラムは、複数のキーワードとして設定された文字列に対してあいまい検索を行うサンプルプログラムです。今回のサンプルプログラムでは、住所データの中に指定した複数のキーワードが該当した場合に、結果として行番号と該当した件数をカウントするサンプルプログラムです。文字列内に探し出したいキーワード（文字列）が複数あるときには、とても便利だと思います。

【プログラムの流れ】
下記のVBAプログラムでは、指定した範囲内で、セル D2 ～ D4 に記載された複数のキーワードをもとに、あいまいな検索を実行して該当する行番号を抽出し、セルに表示するサンプルプログラムです。

①　キーワードを文字列の配列として取得する。
②　キーワードの配列の各要素について、指定した範囲内であいまい検索を実行する。
③　該当する行番号を文字列に結合する。
④　該当件数をカウントする。
⑤　結果をセルに表示する。（該当する行番号全てと件数の合計）

【プログラム実行条件・注意事項】
①　セル D2 ～ D4 に複数のキーワードを入力する必要がある。
②　セル範囲は A2 ～ A20 であることが前提となっているため、必要に応じて修正する必要がある。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　fuzzySearchMultipl01（サンプルプログラム）

'
'
Sub fuzzySearchMultiple() 'あいまい検索
    
    Dim keywords As Variant ' keywords を文字列の配列に変更
    Dim keyword As Variant ' keywords を取り出すための変数
    Dim cell As Range
    Dim resultRows As String
    Dim resultCount As Integer
    
    resultRows = ""
    keywords = Range("D2:D4").Value ' keywords を文字列の配列として取得
    
    For Each keyword In keywords ' keywords の各要素について繰り返し処理を行う
        For Each cell In Range("A2:A20")
            If InStr(1, cell.Value, keyword, vbBinaryCompare) > 0 Then
                If resultRows = "" Then
                        resultRows = CStr(cell.Row)
                    Else
                        resultRows = resultRows & ", " & CStr(cell.Row)
                End If
                
                resultCount = resultCount + 1
            End If
        Next cell
    Next keyword
    
    If resultRows <> "" Then
            Range("E1").Value = "該当行番号:"
            Range("E2").Value = resultRows
            Range("E3").Value = "該当件数: " & resultCount
        Else
            Range("E1").Value = "該当ありません"
    End If

End Sub
'

Sub fuzzySearchMultiple() 'あいまい検索

Dim keywords As Variant ' keywords を文字列の配列に変更

Dim keyword As Variant ' keywords を取り出すための変数

Dim cell As Range

Dim resultRows As String

Dim resultCount As Integer

resultRows = ""

keywords = Range("D2:D4").Value ' keywords を文字列の配列として取得

For Each keyword In keywords ' keywords の各要素について繰り返し処理を行う

For Each cell In Range("A2:A20")

If InStr(1, cell.Value, keyword, vbBinaryCompare) > 0 Then

If resultRows = "" Then

resultRows = CStr(cell.Row)

Else

resultRows = resultRows & ", " & CStr(cell.Row)

End If

resultCount = resultCount + 1

End If

Next cell

Next keyword

If resultRows <> "" Then

Range("E1").Value = "該当行番号:"

Range("E2").Value = resultRows

Range("E3").Value = "該当件数: " & resultCount

Else

Range("E1").Value = "該当ありません"

End If

End Sub

●実行前～実行後 ※プログラム実行後、キーワードを設定した内容に応じて該当した行番号と、その該当件数がE列に表示されました。
（画面クリックして拡大）

EXCEL VBA あいまい検索・正規表現オブジェクトを利用した検索・該当文字を赤字にする（テクニック）

●プログラム説明　(サンプル②)

下記のサンプルプログラムは、複数のキーワードとして設定された文字列に対してあいまい検索を行うサンプルプログラムです。今回のサンプルプログラムでは、正規表現オブジェクトを利用して指定範囲内（データ）の中から指定されたキーワードに基づいて、指定範囲内の一致する文字列を検索し、該当文字のみを赤くする処理を行います。

【正規表現オブジェクトについて】
正規表現オブジェクトは、文字列のパターンマッチングを行うためのオブジェクトです。VBAでは、「VBScript.RegExp」オブジェクトを使用して正規表現を扱うことができます。正規表現を利用することで、特定のパターンに一致する文字列を簡単に検索、置換、抽出することができます。

【プログラムの流れ】
①　検索範囲を設定（セルF2～F4を除く）
②　キーワードを取得
③　正規表現オブジェクトを初期化
④　キーワードをループし、正規表現パターンに設定
⑤　検索範囲の各セルをループ
⑥　セルの値が正規表現のパターンに一致するかテスト
⑦　一致するセルを結果範囲に追加
⑧　セル内の該当文字のみを赤にする

【プログラム実行条件・注意事項】
①　スクリーン更新をオフにして処理速度を向上させていますが、処理が終わった後はスクリーン更新をオンに戻すことが重要です。
②　正規表現はパターンマッチングに非常に便利ですが、複雑なパターンになると理解が難しくなることがあります。適切なパターンを設定することが重要です。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　fuzzySearchMultipl02（サンプルプログラム）

Sub FuzzySearchRegex01()
    ' 変数の宣言
    Dim regex As Object
    Dim keywords() As String
    Dim keyword As Variant
    Dim cell As Range
    Dim resultRange As Range
    Dim searchRange As Range
    Dim searchText As String
    
    ' スクリーン更新をオフにして処理速度を向上させる
    Application.ScreenUpdating = False
    
    ' A2を起点とする検索範囲の設定（セルF2～F4を除く）
    Set searchRange = Range("A2", Range("A2").End(xlDown)).Resize(, 5)
    ' A2を起点とする検索範囲のも文字列を黒にする（初期化）
    searchRange.Font.Color = RGB(0, 0, 0)
        
    ' セルF2～F4からキーワードを取得し、空白のセルは無視する
    searchText = ""
    For i = 2 To 4
        If Range("F" & i).Value <> "" Then
            searchText = searchText & Range("F" & i).Value & ","
        End If
    Next i
    searchText = Left(searchText, Len(searchText) - 1) ' 末尾のカンマを削除
    
    ' 正規表現オブジェクトの初期化
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    
    ' 結果範囲の初期化
    Set resultRange = Nothing
    
    ' searchTextからキーワードを分割
    keywords = Split(searchText, ",")
    
    ' 各キーワードをループ
    For Each keyword In keywords
        ' 現在のキーワードを正規表現のパターンに設定
        regex.Pattern = "(" & keyword & ")" ' キャプチャグループを追加
        
        ' 検索範囲の各セルをループ
        For Each cell In searchRange
            ' セルの値が正規表現のパターンに一致するかテスト
            If regex.test(cell.Value) Then
                ' 一致するセルを結果範囲に追加
                If resultRange Is Nothing Then
                    Set resultRange = cell
                Else
                    Set resultRange = Union(resultRange, cell)
                End If
                
                ' セル内の該当文字のみを赤にする
                Dim matches As Object
                Set matches = regex.Execute(cell.Value)
                For Each Match In matches
                    cell.Characters(Start:=Match.FirstIndex + 1, Length:=Match.Length).Font.Color = RGB(255, 0, 0)
                Next Match
            End If
        Next cell
    Next keyword
    
    ' スクリーン更新をオンに戻す
    Application.ScreenUpdating = True
End Sub

Sub FuzzySearchRegex01()

' 変数の宣言

Dim regex As Object

Dim keywords() As String

Dim keyword As Variant

Dim cell As Range

Dim resultRange As Range

Dim searchRange As Range

Dim searchText As String

' スクリーン更新をオフにして処理速度を向上させる

Application.ScreenUpdating = False

' A2を起点とする検索範囲の設定（セルF2～F4を除く）

Set searchRange = Range("A2", Range("A2").End(xlDown)).Resize(, 5)

' A2を起点とする検索範囲のも文字列を黒にする（初期化）

searchRange.Font.Color = RGB(0, 0, 0)

' セルF2～F4からキーワードを取得し、空白のセルは無視する

searchText = ""

For i = 2 To 4

If Range("F" & i).Value <> "" Then

searchText = searchText & Range("F" & i).Value & ","

End If

Next i

searchText = Left(searchText, Len(searchText) - 1) ' 末尾のカンマを削除

' 正規表現オブジェクトの初期化

Set regex = CreateObject("VBScript.RegExp")

regex.Global = True

regex.IgnoreCase = True

' 結果範囲の初期化

Set resultRange = Nothing

' searchTextからキーワードを分割

keywords = Split(searchText, ",")

' 各キーワードをループ

For Each keyword In keywords

' 現在のキーワードを正規表現のパターンに設定

regex.Pattern = "(" & keyword & ")" ' キャプチャグループを追加

' 検索範囲の各セルをループ

For Each cell In searchRange

' セルの値が正規表現のパターンに一致するかテスト

If regex.test(cell.Value) Then

' 一致するセルを結果範囲に追加

If resultRange Is Nothing Then

Set resultRange = cell

Else

Set resultRange = Union(resultRange, cell)

End If

' セル内の該当文字のみを赤にする

Dim matches As Object

Set matches = regex.Execute(cell.Value)

For Each Match In matches

cell.Characters(Start:=Match.FirstIndex + 1, Length:=Match.Length).Font.Color = RGB(255, 0, 0)

Next Match

End If

Next cell

Next keyword

' スクリーン更新をオンに戻す

Application.ScreenUpdating = True

End Sub

●実行前～実行後　※プログラム実行後、検索範囲内（データ）のセルで該当する複数のキーワードの中から一致する文字列があった場合に、その文字だけを赤色に変更する処理を行います。大量のデータから複数のキーワードを検索するときに便利だと思います。
（画面クリックして拡大）

EXCEL VBA あいまい検索・配列を利用した検索（テクニック）

●プログラム説明　(サンプル③)

今回のプログラムはサンプルプログラム②の一部応用と配列を利用した方法で、Excelワークシート内の指定範囲（A2から始まる5列分の範囲）で、F2～F4セル内にあるキーワードを検索し、キーワードが含まれるセル内の該当文字を赤字にし、同じ行のD列に※印を付ける処理を行います。このコードは、正規表現を使わず、配列を使用して処理速度を高速化しています。

【プログラムの流れ】
①　スクリーン更新をオフにし、処理速度を向上させる
②　検索範囲の設定
③　キーワードの取得
④　配列に検索範囲のデータを格納
⑤　各キーワードをループし、配列内で処理を行う
⑥　該当する文字列と同じ行のD列に※印を付ける
⑦　配列内のデータをワークシートに書き戻す
⑧　該当する文字を赤字に変更
⑨　スクリーン更新をオンに戻す

【プログラム実行条件・注意事項】
・配列を使用しているため、文字色の変更は配列に対して行えません。そのため、ワークシートにデータを書き戻した後に、該当する文字を赤字に変更する処理を追加しています。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　fuzzySearchMultipl03（サンプルプログラム）

'
'
Sub FuzzySearch_Faster()
    ' 変数の宣言
    Dim keywords() As String
    Dim keyword As Variant
    Dim searchRange As Range
    Dim searchText As String
    Dim data As Variant
    Dim i As Long, j As Long

    ' スクリーン更新をオフにして処理速度を向上させる
    Application.ScreenUpdating = False

    ' A2を起点とする検索範囲の設定（セルF2～F4を除く）
    Set searchRange = Range("A2", Range("A2").End(xlDown)).Resize(, 5)
    ' A2を起点とする検索範囲のも文字列を黒にする（初期化）
    searchRange.Font.Color = RGB(0, 0, 0)
    ' D列をクリアー
    Range("D:D").ClearContents
    
    ' セルF2～F4からキーワードを取得し、空白のセルは無視する
    searchText = ""
    For i = 2 To 4
        If Range("F" & i).Value <> "" Then
            searchText = searchText & Range("F" & i).Value & ","
        End If
    Next i
    searchText = Left(searchText, Len(searchText) - 1) ' 末尾のカンマを削除

    ' searchTextからキーワードを分割
    keywords = Split(searchText, ",")

    ' 検索範囲のデータを配列に格納
    data = searchRange.Value

    ' 各キーワードをループ
    For Each keyword In keywords
        ' 配列内で処理を行う
        For i = LBound(data, 1) To UBound(data, 1)
            For j = LBound(data, 2) To UBound(data, 2)
                ' 配列内の値に現在のキーワードが含まれるかチェック
                If InStr(1, data(i, j), keyword, vbTextCompare) > 0 Then
                    ' 該当する文字列と同じ行のD列に※印を付ける
                    data(i, 4) = "※"
                End If
            Next j
        Next i
    Next keyword

    ' 結果をワークシートに書き戻す
    searchRange.Value = data
    
    ' 該当する文字を赤字に変更する
    For Each keyword In keywords
        For Each cell In searchRange
            If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
                cell.Characters(Start:=InStr(1, cell.Value, keyword, vbTextCompare), Length:=Len(keyword)).Font.Color = RGB(255, 0, 0)
            End If
        Next cell
    Next keyword

    ' スクリーン更新をオンに戻す
    Application.ScreenUpdating = True
End Sub

'
'