VBA Programming: Cut and Paste Loop between 2 sheets

  • Thread starter Thread starter CROD
  • Start date Start date
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!!
 
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
 
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
 
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!!!
 
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!!
 
Joel,

It worked!! Well done and much appreciated.....you've literally saved me
hours of work and my sanity!
 
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)
Click to expand...
 
Back
Top