VBA Programming: Cut and Paste Loop between 2 sheets

[CROD]

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!!

 

[Don Guillett]

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

 

[Joel]

This should work. I changed "Sheet 1" to "sheet1" and "Sheet 2" to "Sheet2"
and added a row counter to put results in a new row.


Sub Rectangle1_Click()

RowCount = 8

With Worksheets("Sheet1").Range("a1:a200")
Set c = .Find("NJ1S", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy _
Destination:=Worksheets("Sheet2").Rows(RowCount)
RowCount = RowCount + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If

End With
End Sub

 

[CROD]

Don, thanks for your help and the speedy turnaround!! While it seems to run
(when I click the command button), no copy or paste actually takes place. i
can see something is running, but again, no results.

Is my command button interferring with things: I have "Sub
Rectangle1_Click()". Should replace this with "Sub Copyem()"?

Again, thanks for all your help and expertise!!!

 

[CROD]

Don, thanks for your help and the speedy turnaround!! While it seems to run
(when I click the command button), no copy or paste actually takes place. i
can see something is running, but again, no results.

Is my command button interferring with things: I have "Sub
Rectangle1_Click()". Should replace this with "Sub Copyem()"?

Again, thanks for all your help and expertise!!

 

[CROD]

Joel,

It worked!! Well done and much appreciated.....you've literally saved me
hours of work and my sanity!

 

[CROD]

Don,

Thanks again for your assistance!

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
(e-mail address removed)