【VBA】Findメソッドよりも簡単、早い！高速でセル位置を検索、取得する方法。完全一致、部分一致対応。複数セル取得対応。

Function Search(ByVal Rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean)
'   引数：
'       Rng:検索範囲 (例) ActiveSheet.Range ("A1:Z500")
'       KeyWord:検索する値 (例) "リンゴ",10,7.85
'       Whole:完全一致→True 部分一致→False (例)True
'   戻り値
'       Rangeオブジェクト 見つからなかった場合は「Nothing」

'   検索範囲内の「KeyWord」を検索する関数です。
'   検索範囲を一つずつ判定し、最初に一致したセル範囲を返します。
'   完全一致と部分一致対応できます。
'   非表示のセルも検索かけます
'   検索結果はセル範囲一つだけです。複数の場合が良ければ「search_List」関数を使ってください


    Dim r As Range
    
    '完全一致
    If Whole Then
        For Each r In Rng
            If r.Value = keyWord Then
                Set Search = r
                Exit Function
            End If
        Next
        
    '部分一致
    Else
        For Each r In Rng
            If InStr(r.Value, keyWord) > 0 Then
                Set Search = r
                Exit Function
            End If
        Next
    End If
    
    '見つからなかった時の処理
    '適宜変更してもらって構いません
    Set Search = Nothing
            
End Function

Sub test_search()

    Dim Rng As Range
    Dim result As Range
    
    Set Rng = ThisWorkbook.Worksheets(1).Range("A1:Z5000")
    
    Set result = Search(Rng, "リン", False)
    
    If Not result Is Nothing Then
        Debug.Print result.Address
    Else
        Debug.Print "Nothing"
    End If
    
    '>>$A$1
End Sub

Function search_List(ByVal Rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean)
'   引数：
'       Rng:検索範囲 (例) ActiveSheet.Range ("A1:Z500")
'       KeyWord:検索する値 (例) "リンゴ",10,7.85
'       Whole:完全一致→True 部分一致→False (例)True
'   戻り値
'       配列 見つからなかった場合は「空の配列」

'   検索範囲内の「KeyWord」を検索する関数です。
'   検索範囲を一つずつ判定し、一致したセル範囲を全て配列に含めて返します。
'   完全一致と部分一致対応できます。
'   非表示のセルも検索かけます
'   配列に追加する関数「set_add_Elm」関数、「Is_correct_array」関数を使っています。
'   ↑の関数は当ブログで解説していますので良かった見てください。


    Dim r As Range
    
    '完全一致
    If Whole Then
        For Each r In Rng
            If r.Value = keyWord Then
                Call set_add_Elm(search_List, r)
            End If
        Next
        
    '部分一致
    Else
        For Each r In Rng
            If InStr(r.Value, keyWord) > 0 Then
                Call set_add_Elm(search_List, r)
            End If
        Next
    End If
    
    '見つからなかった時の処理
    '適宜変更してもらって構いません
    If Not Is_correct_array(search_List) Then
        search_List = Array()
    End If
    
            
End Function

Function Is_correct_array(ByVal arrs As Variant)
    Dim a As Long
    
    'なんでもいいが、エラーを生じさせる
    On Error GoTo err
    a = UBound(arrs)

    'エラーが生じたときエラー番号で9か13の場合はFalse
err:
    If err.number = 9 Or err.number = 13 Then
        Is_correct_array = False
    Else
        Is_correct_array = True
    End If
    
End Function

Function set_add_Elm(ByRef arrs As Variant, ByVal elm As Object)
    Dim num As Long
    
    'Is_correct_array関数で配列がエラーを起こす空の状態かどうか判定
    
    'エラーを起こす空の状態
    If Not Is_correct_array(arrs) Then
    
        '要素数が一つ＝「0」で宣言
        ReDim arrs(0)
        Set arrs(0) = elm
    
    'エラーを起こす空の状態ではない
    Else
        num = UBound(arrs)
        ReDim Preserve arrs(num + 1)
        Set arrs(num + 1) = elm
    End If
End Function

Sub test_search_list()
    Dim Rng As Range
    Dim results As Variant
    
    Set Rng = ThisWorkbook.Worksheets(1).Range("A1:Z5000")
    
    results = search_List(Rng, "リン", False)
    
    Dim result As Variant
    For Each result In results
        Debug.Print result.Address & " " & result.Value
    Next
    
End Sub

Sub speed_Test_findmethod()

Debug.Print "これはFindメソッドです"
Dim start, end_ As Date

Dim j As Long

For j = 1 To 5
    start = Now
    
    Dim Rng As Range
    Set Rng = ActiveSheet.Range("A1:A5")
    
    Dim arrs, arr As Variant
    arrs = Array("リンゴ", "バナナ", "メロン", "イチゴ", "スイカ")
    
    
    Dim r As Range
    Dim i As Long
    
    For i = 1 To 5000
        For Each arr In arrs
            Set r = Rng.Find(arr)
            
            Select Case r.Value
                Case "リンゴ": r.Offset(, 1).Value = 1
                Case "バナナ": r.Offset(, 1).Value = 2
                Case "メロン": r.Offset(, 1).Value = 3
                Case "イチゴ": r.Offset(, 1).Value = 4
                Case "スイカ": r.Offset(, 1).Value = 5
            End Select
            Set r = Nothing
        Next
        
        ActiveSheet.Columns("B").ClearContents
    Next i
    
    end_ = Now
    
    Debug.Print Format((end_ - start), "hh:nn:ss")
Next j
End Sub

Function Search2(ByVal rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean)
'   引数：
'       Rng:検索範囲 (例) ActiveSheet.Range ("A1:Z500")
'       KeyWord:検索する値 (例) "リンゴ",10,7.85
'       Whole:完全一致→True 部分一致→False (例)True
'   戻り値
'       Rangeオブジェクト 見つからなかった場合は「Nothing」

'   検索範囲内の「KeyWord」を検索する関数です。
'   検索範囲を一つずつ判定し、最初に一致したセル範囲を返します。
'   完全一致と部分一致対応できます。
'   非表示のセルも検索かけます
'   検索結果はセル範囲一つだけです。複数の場合が良ければ「search_List」関数を使ってください


    Dim r As Range
    Dim s_Row, e_Row As Long
    Dim s_Col, e_Col As Long
    Dim col_, row_ As Long
    Dim ws As Worksheet
    
    '指定された範囲の左上のセルと右上のセルから
    '行と列の範囲を取得
    s_Row = rng(1).Row
    e_Row = rng(rng.Count).Row
    
    s_Col = rng(1).Column
    e_Col = rng(rng.Count).Column
    
    '指定された範囲のシートを取得
    Set ws = rng.Parent
    
    '不完全一致の場合はワイルドカードを付ける
    If Not Whole Then
        keyWord = "*" & keyWord & "*"
    End If
    
    Dim tgtRow As Long  'Match関数で該当のセルの行を取得する
    
    For col_ = s_Col To e_Col
        On Error GoTo err
        tgtRow = WorksheetFunction.Match(keyWord, ws.Range(ws.Cells(s_Row, col_), ws.Cells(e_Row, col_)), 0)
        If tgtRow <> 0 Then
            Set Search2 = ws.Cells(tgtRow, col_)
            Exit Function
        End If

err:
    Resume Next
    Next col_
    
    Set Search2 = Nothing
            
End Function