Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
Dim SearchString As String, FoundAt As String
On Error GoTo Err
Set ws = Worksheets("Sheet3")
Set oRange = ws.Columns(1)
SearchString = "2"
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
FoundAt = aCell.Address
Do While ExitLoop = False
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
FoundAt = FoundAt & ", " & aCell.Address
Else
ExitLoop = True
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
MsgBox "The Search String has been found these locations: " & FoundAt
Exit Sub
Err:
MsgBox Err.Description
End Sub
Try this:
Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
Dim SearchString As String, FoundAt As String
Set ws = Worksheets("Sheet3")
On Error GoTo Err
Set oRange = ws.Cells
SearchString = "2"
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
FoundAt = aCell.Address
Do While ExitLoop = False
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
FoundAt = FoundAt & ", " & aCell.Address
Else
ExitLoop = True
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
MsgBox "The Search String has been found these locations: " & FoundAt
Exit Sub
Err:
MsgBox Err.Description
End Sub