Move rows to another sheet after 6 months

1k Views Asked by At

I've been fiddling with this sheet longer than I should. It is a list of cars that are parked in areas they shouldn't be. After a period of 6 months, I am trying to get them to automatically "Archive" in another sheet of the workbook. Essentially I've been trying to find a macro so that after 6 months from the date in the column, it will automatically cut the row and insert it into the next sheet. Any help would be greatly appreciated. I have toiled on this for 3 days so far and my brain is fried! Apparently I can't post a screenshot because I need a reputation of 10 (Whatever that means) I can totally email it though.

Sub Worksheet_Change(ByVal Target As Excel.Range)

    If Target.Column = 5 Then
        Application.EnableEvents = False
        If Target.Value = TODAY() - 180 Then
            Target.EntireRow.Copy
            Worksheets("Archive").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Target.EntireRow.Delete
            Application.EnableEvents = True

            Exit Sub
        End If
    End If



    If Target.Column <> 5 Then Exit Sub
    If Target.Row = 2 Then Exit Sub
    If Left(Target.Offset(0, -1), 1) = "~" Then Exit Sub
    If Left(Target.Offset(0, -1), 1) = "~" Then Exit Sub
    If Left(Target.Offset(0, -1), 1) = "=Row()-1" Then Exit Sub
    Target.Offset(0, -1).Formula = "=Row()-1"

End Sub
1

There are 1 best solutions below

5
On

Cause your information is not enough, therefore I suppose your records has been sorted by time and the time is located on Column A

Sub MoveRow()
Dim dRow, hRow As Double
Dim s1, s2 As Integer

dRow = 2
hRow = 2
'' number of sheet contain record
s1 = 1
'' num ber of sheet history
s2 = 2

Do While Sheets(s1).Cells(dRow, 1) <> Empty
    ' check if month difference is greater or equal 6
    If DateDiff("m", Sheets(s1).Cells(dRow, 1), Date) >= 6 Then
        Sheets(s1).Cells(dRow, 1).EntireRow.Cut Destination:=Sheets(s2).Cells(hRow, 1)
        Sheets(s1).Cells(dRow, 1).EntireRow.Delete
        hRow = hRow + 1
    Else
        ' if the record is near 6 months, the code will end // reduce time process
        Exit Do
    End If

Loop

MsgBox ("Done")

End Sub