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.

[TABLE="width: 721"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Client ID[/TD]
[TD]Name of Individual [/TD]
[TD] Annual ISP[/TD]
[TD]Room[/TD]
[TD]Time[/TD]
[/TR]
[TR]
[TD]9952[/TD]
[TD]Tom smith[/TD]
[TD]1/10/2017[/TD]
[TD]505[/TD]
[TD]1:30 PM[/TD]
[/TR]
[TR]
[TD]4392[/TD]
[TD]rick jones[/TD]
[TD]1/17/2017[/TD]
[TD]101[/TD]
[TD]2:30pm[/TD]
[/TR]
[TR]
[TD]9941[/TD]
[TD]larry bird[/TD]
[TD]1/23/2017[/TD]
[TD]505[/TD]
[TD]2:30pm[/TD]
[/TR]
[TR]
[TD]9936[/TD]
[TD]ron schapel[/TD]
[TD]1/24/2017[/TD]
[TD]101[/TD]
[TD]2:30pm[/TD]
[/TR]
[TR]
[TD]9942[/TD]
[TD]tom jones[/TD]
[TD]1/26/2017[/TD]
[TD]101[/TD]
[TD]2:30pm[/TD]
[/TR]
[TR]
[TD]9964[/TD]
[TD]bubba shrimp[/TD]
[TD]1/31/2017[/TD]
[TD]101[/TD]
[TD]9:00am[/TD]
[/TR]
[TR]
[TD]1617[/TD]
[TD]davey jones[/TD]
[TD]2/2/2017[/TD]
[TD]505[/TD]
[TD]2:30pm[/TD]
[/TR]
[TR]
[TD]9912[/TD]
[TD]luke skywalker[/TD]
[TD]2/2/2017[/TD]
[TD]505[/TD]
[TD]2:30pm[/TD]
[/TR]
[TR]
[TD]9684[/TD]
[TD]jennifer aniston[/TD]
[TD]2/9/2017[/TD]
[TD]505[/TD]
[TD]2:30pm[/TD]
[/TR]
</tbody>[/TABLE]

 

[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