Try this:

[vba]Sub CompanySearch()
Dim oRange As Range, aCell As Range, bCell As Range, newRange As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
Dim FoundAt As String
Dim destRng As Range


On Error GoTo Err

Set ws = Worksheets(2)
Set oRange = ws.Columns(1)

theText = InputBox("Please enter application name or ID.", "Search Text")
If theText = "" Then
Exit Sub
End If

Set destRng = Worksheets.Add.Range("A1")
Set aCell = oRange.Find(What:=theText, After:=ws.Range("a" & Rows.Count), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then

FoundAt = aCell.Address
aCell.EntireRow.Copy destRng
Set destRng = destRng.Offset(1, 0)
Do While ExitLoop = False
Set bCell = aCell
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Row < bCell.Row Then Exit Do
aCell.EntireRow.Copy destRng
Set destRng = destRng.Offset(1, 0)
FoundAt = FoundAt & ", " & aCell.Address
Else
ExitLoop = True
End If
Loop
Else
MsgBox theText & " not Found"
End If

MsgBox theText & " application data has been added to a new sheet."
MsgBox FoundAt

' Application.Goto Reference:=newRange

Exit Sub
Err:
MsgBox Err.Description
End Sub
[/vba]