Macro to Copy Formula/Formats/Insert Date

[spyldbrat]

Hello,

I have a partial macro written (recorded). I am copying the last row of data from columns the A thru T on the "CURRENT" tab and pasting it to the last row on the "SUMMARY" tab. That part of my macro is working fine.

I now need to add some things and I have no clue how to do it.

After the data is pasted on the last row of "SUMMARY" tab, I need to:

1. Format the row to the same formatting that exists in the row above.
2. Paste the formulas from the row above to the row I just added. The columns I need to copy the formulas from are E, F, H, I, K, L, N, O and Q.
3. In column A of the row I just added, I need to add the current date.

Below is my marcro. Any help would be appreciated!

Sub Sum()

' Sum Macro

    Sheets("Current").Select
    Columns("E:S").Select
    Selection.EntireColumn.Hidden = False
    ActiveWorkbook.Worksheets("Current").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Current").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("A6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Current").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Current").Select
    With ActiveSheet
    .Cells(.Rows.Count, 1).End(xlUp).EntireRow.Select
    .Cells(.Rows.Count, 1).End(xlUp).EntireRow.Copy
    End With        
    Dim lastrow As Long
    lastrow = Sheets("Summary").Range("A65536").End(xlUp).Row
    Sheets("Summary").Select
    Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Current").Select
    Range("R:R,O:O,L:L").Select
    Range("L1").Activate
    ActiveWindow.SmallScroll ToRight:=-3
    Range("R:R,O:O,L:L,I:I").Select
    Range("I1").Activate
    ActiveWindow.SmallScroll ToRight:=-2
    Range("R:R,O:O,L:L,I:I,F:F").Select
    Range("F1").Activate
    Selection.EntireColumn.Hidden = True
    Sheets("Summary").Select
    End Sub

 

[DanteAmor]

Try this

Sub Sum()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim lr1 As Long, lr2 As Long
    
    Application.ScreenUpdating = False
    Set sh1 = Sheets("Current")
    Set sh2 = Sheets("Summary")
    
    sh1.Columns("E:S").EntireColumn.Hidden = False
    sh1.Select
    ActiveWorkbook.Worksheets("Current").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Current").AutoFilter.Sort.SortFields.Add Key:= _
        Range("A6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Current").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
      
    'copy row
    sh1.Cells(Rows.Count, 1).End(xlUp).EntireRow.Copy
    lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
    sh2.Cells(lr2 + 1, "A").PasteSpecial Paste:=xlPasteValues
    'copy formulas
    cols = Array("E", "F", "H", "I", "K", "L", "N", "O", "Q")
    For i = 0 To UBound(cols)
        sh2.Range(cols(i) & lr2).Copy sh2.Range(cols(i) & lr2 + 1)
    Next
    'copy formats
    sh2.Rows(lr2).Copy
    sh2.Rows(lr2 + 1).PasteSpecial Paste:=xlPasteFormats
    'add date
    sh2.Range("A" & lr2 + 1).Value = Date
    '
    sh1.Range("R:R,O:O,L:L,I:I,F:F").EntireColumn.Hidden = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    sh2.Select
    Range("A1").Select
    
    MsgBox "End"
End Sub

 

[spyldbrat]

Works perfectly!!!

Thank you!

 

[spyldbrat]

I am not sure why my macro has me coping the entire last row from the Current tab. I only want to copy columns A to T of the last row and paste that to the Summary tab. Can you make this change?

 

[DanteAmor]

Works perfectly!!!

Thank you!

You're welcome

 

[DanteAmor]

I am not sure why my macro has me coping the entire last row from the Current tab. I only want to copy columns A to T of the last row and paste that to the Summary tab. Can you make this change?

change this

[COLOR=#333333]'copy row
[/COLOR][COLOR=#333333]    sh1.Cells(Rows.Count, 1).End(xlUp).EntireRow.Copy[/COLOR]

By:

    'copy row    
    lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    sh1.Range(sh1.Cells(lr1, "A"), sh1.Cells(lr1, "T")).Copy

 

[spyldbrat]

I get a debug error. The last line is highlighted:

'copy row
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
sh1.Range(sh1.Cells(lr1, "A"), sh1.Cells(lr1, "T")).Copy
sh2.Cells(lr2 + 1, "A").PasteSpecial Paste:=xlPasteValues
'copy formulas
cols = Array("E", "F", "H", "I", "K", "L", "N", "O", "Q")
For i = 0 To UBound(cols)
sh2.Range(cols(i) & lr2).Copy sh2.Range(cols(i) & lr2 + 1)

 

[DanteAmor]

You deleted this line
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row

I put all the code

Sub Sum()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim lr1 As Long, lr2 As Long
    
    Application.ScreenUpdating = False
    Set sh1 = Sheets("Current")
    Set sh2 = Sheets("Summary")
    
    sh1.Columns("E:S").EntireColumn.Hidden = False
    sh1.Select
    ActiveWorkbook.Worksheets("Current").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Current").AutoFilter.Sort.SortFields.Add Key:= _
        Range("A6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Current").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
      
    'copy row
    lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    sh1.Range(sh1.Cells(lr1, "A"), sh1.Cells(lr1, "T")).Copy


    lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
    sh2.Cells(lr2 + 1, "A").PasteSpecial Paste:=xlPasteValues
    'copy formulas
    cols = Array("E", "F", "H", "I", "K", "L", "N", "O", "Q")
    For i = 0 To UBound(cols)
        sh2.Range(cols(i) & lr2).Copy sh2.Range(cols(i) & lr2 + 1)
    Next
    'copy formats
    sh2.Rows(lr2).Copy
    sh2.Rows(lr2 + 1).PasteSpecial Paste:=xlPasteFormats
    'add date
    sh2.Range("A" & lr2 + 1).Value = Date
    '
    sh1.Range("R:R,O:O,L:L,I:I,F:F").EntireColumn.Hidden = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    sh2.Select
    Range("A1").Select
    
    MsgBox "End"
End Sub

 

[spyldbrat]

Looks good.

 

[DanteAmor]

Let me know if you have any doubt.