I changed the loop structure slightly and made the first match object separate to the subsequent matches. This seems to work for single or multiple matches. Let me know how you go.

[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 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
Set destRng = Worksheets.Add.Range("A1")
FoundAt = aCell.Address
aCell.EntireRow.Copy destRng
Set destRng = destRng.Offset(1, 0)
Set bCell = aCell
Do
Set bCell = oRange.FindNext(After:=bCell)
If Not bCell Is Nothing Then
If aCell.Row = bCell.Row Then
Exit Do
Else
bCell.EntireRow.Copy destRng
Set destRng = destRng.Offset(1, 0)
FoundAt = FoundAt & ", " & bCell.Address
End If
Else
Exit Do
End If
Loop
Else
MsgBox theText & " not Found"
Exit Sub
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]