Disconnected
11-19-2012, 03:47 PM
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:
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
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:
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