VBA Programming: Cut and Paste Loop between 2 sheets

C

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

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
 
J

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
 
C

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

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

CROD

Joel,

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

CROD

Don,

Thanks again for your assistance!

Don Guillett said:
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)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top