try this. UN tested

sub copyem()
With Worksheets("Sheet 1").Range("a1:a200")
Set c = .Find("NJ1S", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
'========
lr=sheets("sheet 2").cells(rows.count,"a").end(xlup).row+1
c.EntireRow.Copy sheets("sheet 2").rows(lr)
'=========
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If

End With
end sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"CROD" wrote in message
...
I can not get the following code to find all values "x" within (column A
of
sheet 1); copy each of these EntireRows; find the first available row (or
a
start row) in sheet 2 and paste all rows from sheet 1(all via a command
button):

Sub Rectangle1_Click()

Worksheets("Sheet 1").Select

With Worksheets("Sheet 1").Range("a1:a200")
Set c = .Find("NJ1S", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy
Set c = .FindNext(c)
'Worksheets("Sheet 2").Select
'Worksheets("Sheet 2").Range("a8:a8").Select
'Worksheets("Sheet 2").Paste
'Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If

End With
End Sub

So far I can find and copy the rows sequentially, but, can only paste
undesired results. I've tried numerous iterations.....Help Please!!