Sub TestFindAll()
Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Set SearchRange = Range("A1:A10")
FindWhat = 77
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
MsgBox ("Value Found In Cell: " & FoundCell.Row)
Next FoundCell
End If
End Sub
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
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
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
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
