Select Rows before today & Copy PasteValue Numbers

[bcurrey]

I have a spreadsheet that summarizes basic inbound/outbound numbers each day. Columns B&C are COUNTIFS off of a SQL table on a separate tab. The SQL code only keeps the most recent 7 days of data stored in the workbook.

I need VBA that will select the row prior to today, Copy & PasteValues so that the numbers don't get lost after 7 days pass.

Any ideas? Thanks!

Date	Keyed	Receipts	# to key
4/25/2018	315	1245	930
4/26/2018	540	356	746
4/27/2018	0	0	746
4/30/2018	0	0	746
5/1/2018	0	0	746
5/2/2018	0	0	746
5/3/2018	0	0	746
5/4/2018	0	0	746
5/7/2018	0	0	746
5/8/2018	0	0	746
5/9/2018	0	0	746
5/10/2018	0	0	746
5/11/2018	0	0	746
5/14/2018	0	0	746
5/15/2018	0	0	746
5/16/2018	0	0	746

<tbody>
</tbody>

 

[alansidman]

try this

  Sub SavePrior()    Dim s1 As Worksheet, s2 As Worksheet
    Dim lr As Long, lr2 As Long, i As Long
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To lr
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        If s1.Range("A" & i) < Date Then
            s1.Range("A" & i & ":D" & i).Copy
            s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Action Complete"
End Sub

 

[bcurrey]

Awesome Alan! It works perfect. I really appreciate it!!

try this

  Sub SavePrior()    Dim s1 As Worksheet, s2 As Worksheet
    Dim lr As Long, lr2 As Long, i As Long
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To lr
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        If s1.Range("A" & i) < Date Then
            s1.Range("A" & i & ":D" & i).Copy
            s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Action Complete"
End Sub