VBA: Move row to bottom of sheet after current date has passed

[munsent]

I want to move the top row down to the bottom of the sheet once the current date has passed. I think VBA code would work best, but am new to using VBA. I am attaching a mini sheet. I see code in previous posts for moving a row to a new sheet or to delete the row once it is moved. I need the row to remain intact. Any assistance would be appreciated.

DWU-KERNEL ACTIVITIES.xlsx
	A	B	C	D	E	F	G
1	DWU Baseball
2	Date	Time	Opponent		Producer	Camera Person	Announcer
3	3/2/2025	12:00 PM	Northern State		Caleb	Zach	Caleb
4		3:00 PM	Northern State		Caleb	Zach	Caleb
5
6	3/18/2025	3:00 PM	Dakota State
7
8	3/21/2025	12:00 PM	Hastings			Dane
9		2:30 PM	Hastings			Dane
10
11	3/25/2025	TBA	Valley City State
12
13	3/29/2025	1:00 PM	Doane
14		3:30 PM	Doane
15
16	4/5/2025	1:00 PM	Mount Marty
17		3:00 PM	Mount Marty
18
19	4/6/2025	1:00 PM	Mount Marty			Zach
20		3:00 PM	Mount Marty			Zach
21
22	4/12/2025	TBA	Northwestern
23		TBA	Northwestern
24
25	4/13/2025	1:00 PM	Morningside
26		3:30 PM	Morningside
27
28	4/19/2025	TBA	Briar Cliff
29		TBA	Briar Cliff
30
31
32
Sheet2

 

[6StringJazzer]

I would recommend that your data include the date on every row of data. I also recommend that you get rid of blank rows.

Also, never use merged cells.

You could also combine A & B into a single date/time value, although that's not strictly needed.

What you are asking could be done with VBA but I am not a fan of physically moving around data to indicate its status.

My suggestion is to add a new column called PASSED with the following formula:
=A3<TODAY()
It will show TRUE or FALSE.

Then select all the columns and apply AutoFilter.

Then sort first by PASSED then by Date. Repeat the sort as needed. If aboslutely required, the sort could be automated with VBA, which would be much simpler to write if you make the changes as above.

$scratch.xlsm
	A	B	C	D	E	F	G	H
1	DWU Baseball
2	Date	Time	Opponent		Producer	Camera Person	Announcer	PASSED
3	3/18/2025	3:00:00 PM	Dakota State					FALSE
4	3/21/2025	12:00:00 PM	Hastings			Dane		FALSE
5	3/21/2025	2:30:00 PM	Hastings			Dane		FALSE
6	3/25/2025	TBA	Valley City State					FALSE
7	3/29/2025	1:00:00 PM	Doane					FALSE
8	3/29/2025	3:30:00 PM	Doane					FALSE
9	4/5/2025	1:00:00 PM	Mount Marty					FALSE
10	4/5/2025	3:00:00 PM	Mount Marty					FALSE
11	4/6/2025	1:00:00 PM	Mount Marty			Zach		FALSE
12	4/6/2025	3:00:00 PM	Mount Marty			Zach		FALSE
13	4/12/2025	TBA	Northwestern					FALSE
14	4/12/2025	TBA	Northwestern					FALSE
15	4/13/2025	1:00:00 PM	Morningside					FALSE
16	4/13/2025	3:30:00 PM	Morningside					FALSE
17	4/19/2025	TBA	Briar Cliff					FALSE
18	4/19/2025	TBA	Briar Cliff					FALSE
19	3/2/2025	12:00:00 PM	Northern State		Caleb	Zach	Caleb	TRUE
20	3/2/2025	3:00:00 PM	Northern State		Caleb	Zach	Caleb	TRUE
munsent

Cell Formulas
Range	Formula
H3:H20	H3	=A3<TODAY()

 

[Logit]

VBA approach :

Option Explicit

Sub MoveOldRows()
    Dim ws As Worksheet
    Dim lastRow As Long, destRow As Long, i As Long
    Dim currentDate As Date

    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet name

    ' Get the current date
    currentDate = Date

    ' Find the last used row in the worksheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Find the first unused row at the bottom for moved rows
    destRow = lastRow + 1

    ' Loop through rows from bottom to top
    For i = lastRow To 2 Step -1
        ' Check if the cell in column A contains a date older than the current date
        If IsDate(ws.Cells(i, "A").Value) And ws.Cells(i, "A").Value < currentDate Then
            ' Copy the entire row to the destination row
            ws.Rows(i).Copy Destination:=ws.Rows(destRow)
            ' Increment the destination row
            destRow = destRow + 1
            ' Delete the original row
            ws.Rows(i).Delete
        End If
    Next i

    ' Delete any blank rows (optional)
    For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
        If Application.WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
            ws.Rows(i).Delete
        End If
    Next i

    MsgBox "Rows moved and blank rows deleted!", vbInformation
End Sub