SOLVED

Macro/VBA to move + delete entries based on date

Copper Contributor

Hey!

 

I haven't been able to figure this out for about a week now. I have a sheet for work that is used to check if clients have visited within the past two weeks. I would like to move rows over 14 days old to another sheet on the same file and then delete those same entries from the main sheet. The dates are stored in column a formatted as dd.mm.yyyy. I would ideally like to only move columns a-i, because columns j and k have data that doesn't need to be carried over, but if that is more trouble than it is worth the whole row is fine.

 

I also am not super familiar with running Macros/VBAs and am wondering if it runs each time the sheet is opened?

 

Any help is greatly appreciated!

4 Replies

@joeycc 

I'd leave all data on the one sheet, and use a filter on the date column to show or hide rows as needed.

I don't think this would work in my situation because I have a function that uses the entries on the sheet to check whether a client has come in the last few weeks. So, I need the one main sheet to only have two weeks worth of entries
best response confirmed by joeycc (Copper Contributor)
Solution

@joeycc 

Sub fourteendays()

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim lastrow As Long
Dim i As Long
Dim k As Long
Dim todaydate As Date

todaydate = Date

Set ws = Worksheets("Tabelle1")
Set ws1 = Worksheets("Tabelle2")

k = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
For i = 2 To lastrow
    
If Cells(i, 1).Value <> "" Then
If Cells(i, 1).Value < todaydate - 14 Then

    ws.Range("A" & i, "I" & i).Copy Destination:=ws1.Range("A" & k + 1)
    k = k + 1
    ws.Rows(i).Delete
    i = i - 1
     
Else
End If
Else
End If

Next i

Application.CutCopyMode = False

End Sub

Maybe with these lines of code. In the attached file you can click the button in cell N2 to run the macro. The dates are in column A of sheet "Tabelle1" and in column B to K are random numbers for this example.

worked perfectly once I converted the dates back to US format, thanks a ton !
1 best response

Accepted Solutions
best response confirmed by joeycc (Copper Contributor)
Solution

@joeycc 

Sub fourteendays()

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim lastrow As Long
Dim i As Long
Dim k As Long
Dim todaydate As Date

todaydate = Date

Set ws = Worksheets("Tabelle1")
Set ws1 = Worksheets("Tabelle2")

k = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
For i = 2 To lastrow
    
If Cells(i, 1).Value <> "" Then
If Cells(i, 1).Value < todaydate - 14 Then

    ws.Range("A" & i, "I" & i).Copy Destination:=ws1.Range("A" & k + 1)
    k = k + 1
    ws.Rows(i).Delete
    i = i - 1
     
Else
End If
Else
End If

Next i

Application.CutCopyMode = False

End Sub

Maybe with these lines of code. In the attached file you can click the button in cell N2 to run the macro. The dates are in column A of sheet "Tabelle1" and in column B to K are random numbers for this example.

View solution in original post