VBA code to move row with expired date to bottom of spreadsheet

[lakke2120]

Hello,

I am looking for a code to move a row with a expired date in one of the columns to the bottom of my spreadsheet so that the rows on top consist of today's date followed by the future dates in ascending order. It may be easier to auto sort. As long as today's date is on top followed by future dates in ascending order. Thank you very much.

Client ID	Name of Individual	Annual ISP	Room	Time
9952	Tom smith	1/10/2017	505	1:30 PM
4392	rick jones	1/17/2017	101	2:30pm
9941	larry bird	1/23/2017	505	2:30pm
9936	ron schapel	1/24/2017	101	2:30pm
9942	tom jones	1/26/2017	101	2:30pm
9964	bubba shrimp	1/31/2017	101	9:00am
1617	davey jones	2/2/2017	505	2:30pm
9912	luke skywalker	2/2/2017	505	2:30pm
9684	jennifer aniston	2/9/2017	505	2:30pm

<colgroup><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[Scott T]

See if this does what you want. I assumed that Client was in Column A and the headers were in row 1

Sub mysort()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row


Cells(2, 1).Activate
    Selection.CurrentRegion.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C" & lr) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:E" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
For i = lr To 2 Step -1
    If Cells(i, 3) < Date And lr > 1 Then
        Range("A" & i).EntireRow.Cut
        Range("A" & lr + 1).EntireRow.Insert shift:=xlDown
        lr = Cells(Rows.Count, 1).End(xlUp).Row
    End If
Next i
    
End Sub