PDA

View Full Version : [SOLVED] VBA to Paste top rows to bottom 4 rows as values



nirvehex
03-06-2016, 02:30 PM
Hi All,

I have a code that copies rows 2 - 5, in columns C to I and pastes it as values to the lastrow + 1.




Sub Recommendation()
Dim last4 As String, last4format As String

Sheets("Recommendation").Select
last4 = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1

Range("C2:I5").Select
Selection.Copy
Range("C" & last4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub



I'm stuck on a few items now. (1) I'm trying to figure out how to paste the formatting only from the 4 rows directly above the new 4 I just pasted but include the formatting from columns A - N. Some help there would be appreciated.

(2) I also need to copy the formula from the previous 4 rows in column J down to the newly pasted 4 rows, and (3) I need to copy the last row in column A on a tab called "Data Table" to column A in each of the 4 newly rows I just pasted.

Thank to anyone who can help here! :)

nirvehex
03-06-2016, 08:36 PM
So I did some more work on the code and the questions I outlined above.

Here is the new code so far:



Sub Recommendation()
Dim last4 As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Recommendation")
Set ws2 = ThisWorkbook.Worksheets("Recommendation")

Sheets("Recommendation").Select
last4 = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1

Range("C2:I5").Select
Selection.Copy
Range("C" & last4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Recommendation").Select
Range("A1").Select
Selection.End(xlDown).Offset(-3, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Selection.Offset(4, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Data Table").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.Copy
Sheets("Recommendation").Select
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub


It's still pretty sloppy and I was hoping someone could write it a little more efficiently. I still can't figure out how to copy the formula from the previous 4 rows in column J down to the newly pasted 4 rows in column J.

Thank you to anyone who can help me out here :)

jolivanes
03-06-2016, 11:40 PM
Does this work?



Sub Maybe()
Dim lr As Long
lr = Cells(Rows.Count, 3).End(xlUp).Row
Application.ScreenUpdating = False
Range("C2:I5").Copy Cells(lr + 1, 3)
Range(Cells(lr + 1, 1), Cells(lr + 4, 1)).Value = Sheets("Data Table").Cells(Rows.Count, 1).End(xlUp).Value
Range(Cells(lr - 3, 1), Cells(lr, 14)).Copy
Range(Cells(lr + 1, 1), Cells(lr + 4, 14)).PasteSpecial Paste:=xlPasteFormats
Range(Cells(lr, 10), Cells(lr + 4, 10)).FillDown
Application.ScreenUpdating = True
End Sub

nirvehex
03-09-2016, 07:34 PM
No unfortunately I get an error when I run it.

I've uploaded a sample file so you can see exactly what I'm trying to do. If you click on "Recommendation" tab and run the "Recommendation" Macro you see that it copies the date in the last row from the "Data Table" tab as well as the four rows atop the "Recommendation" tab to the bottom and adds them as a new set of 4 rows. What doesn't get copied is the formula in the B column and the formulas in the J column.

Again here is my code called "Recommendation". Thanks for the help :)



Sub Recommendation()
Dim last4 As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Recommendation")
Set ws2 = ThisWorkbook.Worksheets("Recommendation")

Sheets("Recommendation").Select
last4 = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1

Range("C2:I5").Select
Selection.Copy
Range("C" & last4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Recommendation").Select
Range("A1").Select
Selection.End(xlDown).Offset(-3, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Selection.Offset(4, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Data Table").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.Copy
Sheets("Recommendation").Select
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub
1560015600

jolivanes
03-09-2016, 10:11 PM
No unfortunately I get an error when I run it.
That does not help if you don't tell us what kind of error.


Your code has a lot of selecting that you should shy away from. Slows code down and most of the time is not required.


Why this?

Set ws1 = ThisWorkbook.Worksheets("Recommendation")
Set ws2 = ThisWorkbook.Worksheets("Recommendation")


The following works on your example workbook that is attached in the previous post.

Sub Maybe()
Dim lr As Long
lr = Cells(Rows.Count, 3).End(xlUp).Row
Application.ScreenUpdating = False
Range("C2:I5").Copy Cells(lr + 1, 3)
Range(Cells(lr + 1, 1), Cells(lr + 4, 1)).Value = Sheets("Data Table").Cells(Rows.Count, 1).End(xlUp).Value
Range(Cells(lr - 3, 1), Cells(lr, 14)).Copy
Range(Cells(lr + 1, 1), Cells(lr + 4, 14)).PasteSpecial Paste:=xlPasteFormats
Range(Cells(lr - 3, 10), Cells(lr, 10)).Copy Cells(lr + 1, 10)
Cells(lr - 3, 2).Copy Cells(lr + 1, 2)
Application.ScreenUpdating = True
End Sub

nirvehex
03-20-2016, 02:07 PM
Thank you jolivanes! That worked perfectly and it is so much quicker, you're right :) I knew there had to be a better way.

Hey I was wondering if you might be able to help me out with my post here: http://www.vbaexpress.com/forum/showthread.php?55328-Extracting-minimum-and-maximum-points-above-and-below-moving-average

It has several views, but no replies :(. I have an attached sample file for it as well.

Thanks again!

snb
03-20-2016, 03:32 PM
I'd suggest:


Sub M_snb()
With Sheet7.Cells(1).CurrentRegion
.Offset(.Rows.Count - 4).Resize(4).Copy .Offset(.Rows.Count).Resize(4)
.Offset(.Rows.Count).Resize(4, 1) = Sheet1.Cells(Rows.Count, 1).End(xlUp)
End With
End Sub

nirvehex
03-20-2016, 04:04 PM
snb,

Sorry, I'm a bit confused. Is this your suggestion for the code that jolivanes was working on above or was this a suggestion to the link I posted to a different thread?

Thanks.

snb
03-21-2016, 01:01 AM
If you analyse and test my suggestion you'll notice that the former is the matter.