Results 1 to 5 of 5

Thread: FindAll Function In VBA

  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10

    Lightbulb FindAll Function In VBA

    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.

    Code:
    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..

    Code:
    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 !!
    Last edited by Admin; 08-18-2012 at 02:54 PM.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  2. #2
    Senior Member LalitPandey87's Avatar
    Join Date
    Sep 2011
    Posts
    222
    Rep Power
    14
    So useful. its working.
    Thanx Again.

  3. #3
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13

    Here is an alternative FindAll function which I have posted in the past

    Here is a FindAll function that you may find useful. This function, which cannot be used as a UDF, will return a range consisting of all the cells that meet your search criteria (which you can then use directly in your code or obtain any of its parameter values, such as the Address for the range of cells) or perform an action on (such as Select them). Here is the function along with its attendant enumeration object...

    Code:
    Enum LookAtConstants
      xlWholeCell = xlWhole
      xlPartCell = xlPart
    End Enum
    
    Function FindAll(FindWhat As String, Optional LookAt As LookAtConstants = xlWholeCell, _
                     Optional MatchCase As Boolean = False, Optional SearchAddress As String) As Range
      Dim LastRowPlusOne As Long, RowOffset As Long, ColOffset As Long, SearchRange As Range, CopyOfSearchRange As Range
      On Error Resume Next
      If Len(SearchAddress) = 0 Then
        Set SearchRange = Selection
      Else
        Set SearchRange = Range(SearchAddress)
        If SearchRange Is Nothing Then Exit Function
      End If
      LastRowPlusOne = Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row + 1
      If SearchRange Is Nothing Then Set SearchRange = Selection
      If Rows.Count - LastRowPlusOne < SearchRange.Rows.Count Then
        MsgBox "SearchRange contains too many rows!", vbCritical, "Search Range Too Large"
        Exit Function
      End If
      RowOffset = LastRowPlusOne - SearchRange(1).Row
      ColOffset = SearchRange(1).Column - 1
      Set CopyOfSearchRange = Cells(LastRowPlusOne, 1).Resize(SearchRange.Rows.Count, SearchRange.Columns.Count)
      Application.ScreenUpdating = False
      With CopyOfSearchRange
        SearchRange.Copy .Cells(1)
        .Replace FindWhat, "=" & FindWhat, LookAt, , MatchCase
        Set FindAll = .SpecialCells(xlCellTypeFormulas).Offset(-RowOffset, ColOffset)
        .Clear
      End With
      Application.ScreenUpdating = True
    End Function
    This function has one required argument, the FindWhat which is obviously the text you wish to search for, and three optional argument... the LookAt argument which makes uses the Enun constants xlWholeCell and xlPartCell which controls whether the text being searched for must fill the whole cell or not (the default value is xlWholeCell)... the MatchCase argument which controls whether the text being searched for must match the letter casing exactly or not (the default is False meaning the search is case insensitive)... and the SearchAddress argument which is a string value representing the address of the contiguous cell range to be searched (the default value, if omitted, is the currectly selected range of cells). Note that this function does not use any loops and, as such, should execute relatively quickly; but note that it does make use of the empty cells below the last piece of data, so the number of rows being searched must be equal to or less than the unused number of rows on the worksheet (an error will be raised if not).

    Here is an example call to this function using all the arguments...

    Code:
    ' Relying on positional arrangement
    Debug.Print FindAll("cut", xlWholeCell, False, "A1:C10").Address
    
    ' Using the named arguments for clarity
    Debug.Print FindAll(FindWhat:="cut", LookAt:=xlWholeCell, MatchCase:=False, SearchAddress:="A1:C10").Address
    Last edited by Rick Rothstein; 02-25-2012 at 07:28 AM.

  4. #4
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Thanks Rick...
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  5. #5
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi Rick,

    Welcome to ExcelFox !!

    Thanks for sharing this and expect many more from you

    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

Similar Threads

  1. UDF (user defined function) replacement for Excel's DATEDIF function
    By Rick Rothstein in forum Rick Rothstein's Corner
    Replies: 21
    Last Post: 03-07-2015, 09:47 PM
  2. IsDate() Function : VBA
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 06-03-2013, 10:00 PM
  3. CHR() Function VBA
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 1
    Last Post: 05-20-2013, 08:50 AM
  4. CurDir() function VBA
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 05-17-2013, 12:32 AM
  5. FindAll function
    By Rick Rothstein in forum Rick Rothstein's Corner
    Replies: 1
    Last Post: 06-12-2012, 02:37 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •