问查找并选择工作表中的所有匹配项

EN

Option Explicit

Sub selectNext()
    
    Const CriteriaCellAddress As String = "E2"
    Const SearchRangeAddress As String = "A7:AE22"
    
    Dim Criteria As String
    Criteria = Range(CriteriaCellAddress).Value
    
    Dim SearchRange As Range
    Set SearchRange = Range(SearchRangeAddress)

    Dim cel As Range
    Set cel = findNextCell(SearchRange, Criteria)
    If Not cel Is Nothing Then
        cel.Select
    End If

End Sub

Function findNextCell(SearchRange As Range, _
                      ByVal Criteria As String) _
         As Range
    
    Static PreviousCellAddress As String
    Static CurrentCriteria As String
    
    If CurrentCriteria = "" Or CurrentCriteria <> Criteria Then
        CurrentCriteria = Criteria
    End If
    
    Dim NextCell As Range
    Set NextCell = findCell(SearchRange, CurrentCriteria, PreviousCellAddress)
    
    If Not NextCell Is Nothing Then
        ' Criteria was found.
        PreviousCellAddress = NextCell.Address
    Else
        ' Criteria was not found.
        GoTo NoRange ' Exit.
    End If
    
    Set findNextCell = NextCell
  
ProcExit:
    Exit Function

NoRange:
    Debug.Print "Could not find '" & Criteria & "' in range '" _
               & SearchRange.Address(0, 0) & "'."
    GoTo ProcExit
       
End Function

Function findCell(SearchRange As Range, _
                  ByVal Criteria As String, _
                  Optional ByVal PreviousCellAddress As String = "") _
         As Range
    
    If Criteria = "" Then
        GoTo NoCriteria ' Exit.
    End If
    
    If SearchRange Is Nothing Then
        GoTo NoRange ' Exit.
    End If
    
    Dim PreviousCell As Range
    If PreviousCellAddress <> "" Then
        Set PreviousCell = SearchRange.Worksheet.Range(PreviousCellAddress)
        If Intersect(SearchRange, PreviousCell) Is Nothing Then
            GoTo OutOfBounds ' Exit.
        End If
    Else
        Set PreviousCell = SearchRange.Cells(SearchRange.Cells.CountLarge)
    End If
    
    Set findCell = SearchRange.Find(What:=Criteria, _
                                    After:=PreviousCell, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=False)

ProcExit:
    Exit Function
    
NoCriteria:
    Debug.Print "No criteria ('""')."
    GoTo ProcExit

NoRange:
    Debug.Print "No range ('Nothing')."
    GoTo ProcExit

OutOfBounds:
    Debug.Print "The cell '" & PreviousCellAddress _
              & "' is not contained in range '" & SearchRange.Address(0, 0) _
              & "'."
    GoTo ProcExit

End Function

Sub selectNext()
    
    Const CriteriaCellAddress As String = "E2"
    Const FirstRow As Long = 7
    Const ColumnsAddress As String = "A:AE"
    
    ' Define Criteria.
    Dim Criteria As String
    Criteria = Range(CriteriaCellAddress).Value
    
    ' Define Search Range (from first row to last non-blank row).
    Dim SearchRange As Range
    Set SearchRange = getColumnsRange(ActiveSheet, ColumnsAddress, FirstRow)
    
    If Not SearchRange Is Nothing Then
        ' Try to find Next Cell Range.
        Dim cel As Range
        Set cel = findNextCell(SearchRange, Criteria)
        If Not cel Is Nothing Then
            cel.Select
        End If
    End If

End Sub

Function getColumnsRange(Sheet As Worksheet, _
                         Optional ByVal ColumnsAddress As String = "A", _
                         Optional ByVal FirstRow As Long = 1) _
         As Range
    
    ' Define Last Non-Blank Cell Range.
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnsAddress).Find(What:="*", _
                                                 LookIn:=xlFormulas, _
                                                 SearchOrder:=xlByRows, _
                                                 SearchDirection:=xlPrevious)
    ' Check Last Non-Blank Cell Range.
    If rng Is Nothing Then
        GoTo BlankColumns
    End If
    ' Check Last Non-Blank Cell Range row against First Row.
    If rng.Row < FirstRow Then
        GoTo FirstRowBelowLastRow
    End If
    ' Using the row of Last Non-Blank Cell Range, finally define Columns Range.
    Set getColumnsRange = Sheet.Range(Sheet.Columns(ColumnsAddress) _
                                           .Rows(FirstRow), _
                                      Sheet.Columns(ColumnsAddress) _
                                           .Rows(rng.Row))

ProcExit:
    Exit Function
    
BlankColumns:
    Debug.Print "The columns '" & ColumnsAddress & "' are blank."
    GoTo ProcExit

FirstRowBelowLastRow:
    Debug.Print "The last non-blank row (" & rng.Row _
              & ") is above the first row (" & FirstRow & ")."
    GoTo ProcExit
    
End Function

'Uses Range.Find to get a range of all find results within a worksheet
' Same as Find All from search dialog box
'Where search start from First cell and go to last cell.So that we say that search start after lastcell = .cells(.cells.count)
Function FindAll(rng As Range, What As Variant, Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlPart, Optional SearchOrder As XlSearchOrder = xlByRows, Optional SearchDirection As XlSearchDirection = xlNext, Optional MatchCase As Boolean = False, Optional MatchByte As Boolean = False, Optional SearchFormat As Boolean = False) As Range
'For containing matched range.
Dim SearchResult As Range
'For first matched address.
Dim firstMatch As String
With rng
    'Find first Matched result.
    Set SearchResult = .Find(What, .Cells(.Cells.Count), LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
    'If SearchResult  Nothing then set the firstmatched range address to the variable.
    If Not SearchResult Is Nothing Then
        firstMatch = SearchResult.Address
        Do
            If FindAll Is Nothing Then
                'FindAll = nothing then set FindAll = first match cell
                Set FindAll = SearchResult
            Else
                'If FindAll contain some range then union previous range with new match result range.
                Set FindAll = Union(FindAll, SearchResult)
            End If
            'Change the SearchResult to next matched cell.
            'FindNext will start from previous SearchResult address.
            Set SearchResult = .FindNext(SearchResult)
        'Loop until the SearchResult contains no address or address first address.
        Loop While Not SearchResult Is Nothing And SearchResult.Address  firstMatch
    End If
End With
End Function