Расширенная функция поиска на листе Excel

Function FindAll(SearchRange As Range, _
                 FindWhat As Variant, _
                 Optional LookIn As XlFindLookIn = xlValues, _
                 Optional LookAt As XlLookAt = xlWhole, _
                 Optional SearchOrder As XlSearchOrder = xlByRows, _
                 Optional MatchCase As Boolean = False, _
                 Optional BeginsWith As String = vbNullString, _
                 Optional EndsWith As String = vbNullString, _
                 Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FindAll
    ' This searches the range specified by SearchRange and returns a Range object
    ' that contains all the cells in which FindWhat was found. The search parameters to
    ' this function have the same meaning and effect as they do with the
    ' Range.Find method. If the value was not found, the function return Nothing. If
    ' BeginsWith is not an empty string, only those cells that begin with BeginWith
    ' are included in the result. If EndsWith is not an empty string, only those cells
    ' that end with EndsWith are included in the result. Note that if a cell contains
    ' a single word that matches either BeginsWith or EndsWith, it is included in the
    ' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
    ' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
    ' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
    ' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
    ' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
    ' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
    ' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim FoundCell As Range, FirstFound As Range, LastCell As Range, rngResultRange As Range
    Dim XLookAt As XlLookAt, Include As Boolean, CompMode As VbCompareMethod
    Dim Area As Range, MaxRow As Long, MaxCol As Long, BeginB As Boolean, EndB As Boolean
 
    CompMode = BeginEndCompare
    XLookAt = LookAt: If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then XLookAt = xlPart
 
    ' this loop in Areas is to find the last cell of all the areas. That is, the cell whose row
    ' and column are greater than or equal to any cell in any Area.
    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then MaxRow = .Cells(.Cells.Count).Row
            If .Cells(.Cells.Count).Column > MaxCol Then MaxCol = .Cells(.Cells.Count).Column
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
    Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
                                     LookIn:=LookIn, LookAt:=XLookAt, _
                                     SearchOrder:=SearchOrder, MatchCase:=MatchCase)
 
    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False    ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(FoundCell.Text, Len(BeginsWith)), _
                               BeginsWith, BeginEndCompare) = 0 Then Include = True
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(FoundCell.Text, Len(EndsWith)), _
                               EndsWith, BeginEndCompare) = 0 Then Include = True
                End If
            End If
            If Include = True Then
                If rngResultRange Is Nothing Then
                    Set rngResultRange = FoundCell
                Else
                    Set rngResultRange = Application.Union(rngResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then Exit Do
            If (FoundCell.Address = FirstFound.Address) Then Exit Do
        Loop
    End If
    Set FindAll = rngResultRange
End Function