Search, find, copy from sheet1 and paste into sheet2

[lothario]

Hi,

I have:

Workbook called "Fruits".
=> It contains sheets "s1" and "s2".
=> "s1" contains 8,000 rows of data.
=> "s1" contains the columns "Id", "Description", "Color", etc ...

I would like to:

=> Have a button in called "Find Fruits" in "s2".

=> This button should take the (search) criteria from
cell "b3" in "s2".

=> Where "b3" may contain the text. For example, "gre".

=> So when the button is clicked the VBA code would find all
the rows in "s1" where the "Color" contains the text "gre".

=> An example row would be 896, Pear, Green, ...

=> Note that this row is selected because "gre" is contained
in "Green". (not case sensitive)

=> So "ree" would also work.

=> So as long as the matched item *contains* the required
text, it is enough.

=> All the rows in "s1" that match should be copied and
pasted into "s2" starting at cell d6.

Can you please give me the VBA code for the "Find Fruits" button?


Thanks,
Luther

 

[Bob Phillips]

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Bob Phillips]

Luther,

This should do it

Sub Find()
Dim sFound As String
Dim cLastRow As Long
Dim iRow As Long
Dim oFound As Range
Dim oWS1 As Worksheet
Dim ows2 As Worksheet

Set oWS1 = Worksheets("s1")
Set ows2 = Worksheets("s2")

cLastRow = oWS1.Cells(Rows.Count, "A").End(xlUp).Row
iRow = 6

With oWS1.Columns(3)
Set oFound = .Find(what:=ows2.Range("B3"))
If Not oFound Is Nothing Then
sFound = oFound.Address
Do
oFound.EntireRow.Copy Destination:=ows2.Cells(iRow, "A")
iRow = iRow + 1
Set oFound = .FindNext(oFound)
Loop While Not oFound Is Nothing And sFound <> oFound.Address
End If
End With

End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[lothario]

Thanks Bob.

 

[Bob Phillips]

Pleasure. I got there in the end <G>

Bob