Microsoft Office Forums - View Single Post

macropod · 07-15-2011, 09:34 PM

Hi atilla,

Try the following macro:

Code:

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

Note: As coded, the macro -
1. deletes entries before 7AM and after 6PM. Modify the '7:00:00' and '18:00:00' to suit your needs.
2. preserves only the earliest valid entry for users with multiple entries on the same date. To keep only the last valid entry, change the last instance of 'xlAscending' to 'xlDescending'.