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

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

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

'
'
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
'

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

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 あいまい検索・配列を利用した検索（テクニック）

'
'
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

'
'