VBA to Paste top rows to bottom 4 rows as values

[nirvehex]

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]

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]

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 Su

b

[nirvehex]

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

stuff 2 - test.xlsmstuff 2 - test.xlsm

[jolivanes]

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]

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/show...moving-average

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

Thanks again!

[snb]

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]

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]

If you analyse and test my suggestion you'll notice that the former is the matter.