Solved: Please assist in copying row found during Do Loop to new sheet.

[Disconnected]

Hello everyone. Here's the conceptual, the problem and the code.

Conceptual:

Users clicks on the button to find a partial-match of a text string. For every row that the text string is found in (which will only be found in Column A), I want that row copied to a new spreadsheet.

For example:

Say I want to find all rows in the Sheet that contain the word "Adobe". I search, each is found, then the row with only "Adobe" (partial match) in Column A is copied to a new Sheet.

Problem:

The sheet I am searching has one value for "Actuate". After the popup, I enter Actuate, it looks through the code once and the value FoundAt becomes $A$30. I can verify this because the MsgBox FoundAt pops up with that value.

Where I run into a problem is that I want that row (30) to be pasted into A1 of the new sheet that was created, and then any subsequent values to be pasted to A2, etc.

No matter how many different variants of paste or copy or insert or whatever I simply cannot get the aCell range to paste correctly into A1 of the new sheet.

Please help. I've scoured these forums all day to no avail.


Code:
[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


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


Worksheets.Add

Set aCell = oRange.Find(What:=theText, 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 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]

[Teeroy]

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]

[Disconnected]

Thank you so much. This really helped. :o)

I had to tweak some things but overall it works. There's a slight SNAFU, however:

If I only have one result the loop will not break. Because of the aCell < bCell this will always be the case so the loop cannot exit if aCell = bCell, which it will if there is only one value found.

[Teeroy]

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]

[Disconnected]

Perfect. I love you forever. :o)

Case closed!