FindAll Function In VBA

[Admin]

Hi All,

Here is a Function which return found range. You could use this function to delete,hide,format etc. the range. It's faster than the native Find command in VBA.

Paste this code in a standard module.

Public Enum xl_LookAt
    xl_Whole = 1
    xl_Part = 2
End Enum
Function FINDALL(ByRef RangeToLook As Range, ByVal SearchWhat As String, _
                            Optional ByVal Look_At As xl_LookAt = xl_Whole, _
                            Optional ByVal Match_Case As Boolean = False) As Range
    
    Dim r           As Long
    Dim c           As Long
    Dim UB1         As Long
    Dim UB2         As Long
    Dim strAddress  As String
    Dim k
    
    k = RangeToLook
    
    If IsArray(k) Then
        UB1 = UBound(k, 1)
        UB2 = UBound(k, 2)
        For r = 1 To UB1
            For c = 1 To UB2
                If Look_At = xl_Whole Then
                    If Match_Case Then
                        If k(r, c) = SearchWhat Then
                            strAddress = strAddress & "," & Cells(r, c).Address(0, 0)
                            If Len(strAddress) > 245 Then
                                strAddress = Mid$(strAddress, 2)
                                If FINDALL Is Nothing Then
                                    Set FINDALL = RangeToLook.Range(CStr(strAddress))
                                Else
                                    Set FINDALL = Union(FINDALL, RangeToLook.Range(CStr(strAddress)))
                                End If
                                strAddress = vbNullString
                            End If
                        End If
                    Else
                        SearchWhat = LCase$(SearchWhat)
                        If LCase$(k(r, c)) = SearchWhat Then
                            strAddress = strAddress & "," & Cells(r, c).Address(0, 0)
                            If Len(strAddress) > 245 Then
                                strAddress = Mid$(strAddress, 2)
                                If FINDALL Is Nothing Then
                                    Set FINDALL = RangeToLook.Range(CStr(strAddress))
                                Else
                                    Set FINDALL = Union(FINDALL, RangeToLook.Range(CStr(strAddress)))
                                End If
                                strAddress = vbNullString
                            End If
                        End If
                    End If
                Else
                    If Match_Case Then
                        If InStr(1, k(r, c), SearchWhat, 0) Then
                            strAddress = strAddress & "," & Cells(r, c).Address(0, 0)
                            If Len(strAddress) > 245 Then
                                strAddress = Mid$(strAddress, 2)
                                If FINDALL Is Nothing Then
                                    Set FINDALL = RangeToLook.Range(CStr(strAddress))
                                Else
                                    Set FINDALL = Union(FINDALL, RangeToLook.Range(CStr(strAddress)))
                                End If
                                strAddress = vbNullString
                            End If
                        End If
                    Else
                        SearchWhat = LCase$(SearchWhat)
                        If InStr(1, LCase$(k(r, c)), SearchWhat, 0) Then
                            strAddress = strAddress & "," & Cells(r, c).Address(0, 0)
                            If Len(strAddress) > 245 Then
                                strAddress = Mid$(strAddress, 2)
                                If FINDALL Is Nothing Then
                                    Set FINDALL = RangeToLook.Range(CStr(strAddress))
                                Else
                                    Set FINDALL = Union(FINDALL, RangeToLook.Range(CStr(strAddress)))
                                End If
                                strAddress = vbNullString
                            End If
                        End If
                    End If
                End If
            Next
        Next
        If Len(strAddress) > 1 Then
            strAddress = Mid$(strAddress, 2)
            If FINDALL Is Nothing Then
                Set FINDALL = RangeToLook.Range(CStr(strAddress))
            Else
                Set FINDALL = Union(FINDALL, RangeToLook.Range(CStr(strAddress)))
            End If
            strAddress = vbNullString
        End If
    Else
        If Look_At = xl_Whole Then
            If Match_Case Then
                If k = SearchWhat Then
                    FINDALL = RangeToLook
                End If
            ElseIf LCase$(k) = LCase$(SearchWhat) Then
                FINDALL = RangeToLook
            End If
        Else
            If Match_Case = True Then
                If InStr(1, k, SearchWhat, 0) Then
                    FINDALL = RangeToLook
                End If
            Else
                If InStr(1, LCase$(k), LCase$(SearchWhat), 0) Then
                    FINDALL = RangeToLook
                End If
            End If
        End If
    End If

End Function

and use like..

Sub kTest()
    
    Dim r As Range
    Dim c As Range, t
    
    t = Timer
    Set r = Range("a1:a50000")
    
    Set c = FINDALL(r, "k")
    
    c.Interior.Color = 255
    Debug.Print Timer - t
    
End Sub

Enjoy !!