Sub Cleanup()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim i As Long, LastRow As Long
With ActiveSheet
  LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
  For i = LastRow To 2 Step -1
    If CDate(.Range("B" & i).Value) < CDate("7:00:00") Then
      .Range("A" & i).EntireRow.Delete
    End If
    If CDate(.Range("B" & i).Value) > CDate("18:00:00") Then
      .Range("A" & i).EntireRow.Delete
    End If
  Next
  LastRow = .Range("A" & .Cells.SpecialCells(xlCellTypeLastCell).Row).End(xlUp).Row
  With .Sort
    With .SortFields
      .Clear
      .Add Key:=Range("A1:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
      .Add Key:=Range("D1:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .Add Key:=Range("B1:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range("A1:D" & LastRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  For i = LastRow To 2 Step -1
    If .Range("A" & i).Value & .Range("D" & i).Value = .Range("A" & i - 1).Value & .Range("D" & i - 1).Value Then
      .Range("A" & i).EntireRow.Delete
    End If
  Next
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub