Macro to Copy Formula/Formats/Insert Date

spyldbrat

Board Regular
Joined
May 5, 2002
Messages
199
Office Version
  1. 365
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!

Code:
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
 
Last edited by a moderator:

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try this

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
    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

Board Regular
Joined
May 5, 2002
Messages
199
Office Version
  1. 365
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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

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

By:

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

spyldbrat

Board Regular
Joined
May 5, 2002
Messages
199
Office Version
  1. 365

ADVERTISEMENT

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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
You deleted this line
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row

I put all the code

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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Let me know if you have any doubt.
 

Watch MrExcel Video

Forum statistics

Threads
1,108,709
Messages
5,524,433
Members
409,577
Latest member
Dwg

This Week's Hot Topics

Top