Mercy - Need help with Copy/Paste VBA

[AirgasRob]

My reverse engineering skills have finally failed me =(

I need to copy rows based on a set value in Column A, to a different
worksheet and start on the next empty row. I also need to paste special as
the values in the source sheet are generated via formulas.

Sub CopySAP()

RowCount = 2

With Worksheets("SAPUpload").Range("a3:a200")
Set c = .Find("1", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy _
Destination:=Worksheets("SAPUpload2").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

 

[joel]

Sub CopySAP()

RowCount = 2

With Worksheets("SAPUpload").Range("a3:a200")
Set c = .Find("1", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy
Worksheets("SAPUpload2").Rows(RowCount).PasteSpecial _
paste:=xlpastevalues
RowCount = RowCount + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If

End With

End Sub

 

[Mike H]

Just a matter of personal preference but I prefer to do the paste in one
operation

Sub copyit()
Dim MyRange, MyRange1 As Range
Dim Lastrow As Long
For Each c In Sheets("SAPUpload").Range("A3:A200")
If InStr(c.Value, 1) > 0 Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Copy
Lastrow = Sheets("SAPUpload2").Cells(Rows.Count, "H").End(xlUp).Row
Sheets("SAPUpload2").Range("A" & Lastrow).PasteSpecial
End If
End Sub


Mike

 

[Mike H]

Just a matter of personal preference but I prefer to do the paste in one

operation

And another point compared to your code (as corrected by Joel) my version
runs ~10 times faster without the need to bounce back and forward doing
individual paste operations.

Mike

 

[AirgasRob]

Thanks Joel, as always I learn a little more everytime I come here. The code
works great with one exception. When I run the code a second time it
overwrites what was previously pasted.

 

[AirgasRob]

Mike thank you very much exactly what I was looking for. I only had to make a
few minor changes to get the exact results I wanted. I will post the modified
code for those that may come after me. I made note of the two changes I had
to make.

Sub copyit()
Dim MyRange, MyRange1 As Range
Dim Lastrow As Long
For Each c In Sheets("SAPUpload").Range("A3:A200")
If InStr(c.Value, 1) > 0 Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Copy
Lastrow = Sheets("SAPUpload2").Cells(Rows.Count, "H").End(xlUp).Offset(1,
0).Row '<--Added .Offset(1, 0)
Sheets("SAPUpload2").Range("A" & Lastrow).PasteSpecial Paste:=xlPasteValues
'<--Added Paste:=xlPasteValues
End If
End Sub