Thread: Find rows and delete them based on multiple criteria

Hi, i've searched the forum but couldn't find exactly what I'm after.

I have a macro that looks into a worksheet, filters a column and has to delete rows.

I want to delete those rows based on a set of criteria. Since the criteria have to do with Time, I need it to be over xx:00:00 or under xx:00:00 etc.

Below is the macro and the criteria I want to plug in the "strCriteria =" bit is:
delete all rows where the value is: ">19:00:00 and <07:00:00" or ">10:00:00 and <16:00:00", so basically keep only the rows with data between the hours 7-10am and 4-7pm (I have the hours in number format, just wrote them here as hours to make it simple to understand).

Any suggestions will be greatly appreciated.

macro:

Option Explicit

Sub FilterData()
''''''''''''''''''''''''''
'Written by www.ozgrid.com
''''''''''''''''''''''''''

Dim rRange As Range
Dim strCriteria As String
Dim lCol As Long
Dim rHeaderCol As Range
Dim xlCalc As XlCalculation
Const strTitle As String = "OZGRID CONDITIONAL ROW DELETE"

On Error Resume Next
Step1:
'We use Application.InputBox type 8 so user can select range
Set rRange = Range("a1:d16000")



Step2:
'We use Application.InputBox type 1 so return a number
lCol = 2

Step3:
'We use default InputBox type as we want Text
strCriteria = Range("c3")


'Store current Calculation then switch to manual.
'Turn off events and screen updating
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With


'Remove any filters
ActiveSheet.AutoFilterMode = False

With rRange 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=lCol, Criteria1:=strCriteria
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With

'Remove any filters
ActiveSheet.AutoFilterMode = False

'Revert back
With Application
.Calculation = xlCalc
.EnableEvents = True
.ScreenUpdating = True
End With
On Error GoTo 0
End Sub

a value can never be greater than 19:00 and less than 7:00!
">19:00:00 and <07:00:00"

Originally Posted by Kelshaer

a value can never be greater than 19:00 and less than 7:00!
">19:00:00 and <07:00:00"

Yes you're right, my mistake. I need it to be >19:00:00 OR <07:00:00 in that case

in which column does the time values appear?

Originally Posted by Kelshaer

in which column does the time values appear?

Column B (that's why i got icol=2)

Well, I assumed the times reside in Column B. If not then replace it with whatever you want in the below code.

Sub DeleteTimes()
Dim h As Double, r As Integer, i As Integer
r = Cells.SpecialCells(xlCellTypeLastCell).Row
With ActiveSheet
    For i = r To 1 Step -1
        h = VBA.Hour(.Range("B" & i)) + 60 * VBA.Minute(.Range("B" & i))
        If h < 7 Or h > 19 Then .Rows(i).EntireRow.Delete
        If h > 10 And h < 16 Then .Rows(i).EntireRow.Delete
    Next
End With
End Sub

Originally Posted by Kelshaer

Well, I assumed the times reside in Column B. If not then replace it with whatever you want in the below code.

Thanks, this seems to be working but it's taking a long time as I've got '000s of rows. Isn't there any way to amend the macro in OP as it uses the Filter which speeds things up? It works when I type one criterion, but not for multiple ones.
EDIT: Something seems to be wrong in the macro you posted with how it handles time as it whittled down 15000 rows to about 80!. when there should be a few thousand.

Try this

Sub DeleteTimes()
Application.ScreenUpdating = False
ThisWorkbook.Save
Dim h As Double, r As Integer, i As Integer
r = Cells.SpecialCells(xlCellTypeLastCell).Row
With ActiveSheet
    For i = r To 1 Step -1
        If .Range("B" & i) <> "" Then
            h = VBA.Hour(.Range("B" & i)) + 60 * VBA.Minute(.Range("B" & i))
            If h < 7 Or h > 19 Then .Rows(i).EntireRow.Delete
            If h > 10 And h < 16 Then .Rows(i).EntireRow.Delete
        End If
    Next
End With
Application.ScreenUpdating = True
End Sub

Originally Posted by Kelshaer

Try this

This is much faster due to the screen not updating. The speed is adequate but it seems to remove way too many results, I'm only left with about 80 rows out of 12,000.

The data I got in column be is in the following format:
08:39:03
05:44:22
etc.

Perhaps I need to specify data strings in the macro to represent the time values?

Thank you very much for your help so far.

EDIT: I've figured out where is the issue with your code. It's the 60*vba.minute that causes the trouble as it makes the macro to delete even rows with time data between 7am-10am. Imagine 7:15:00, with 60*minutes it makes the hour element go over 10am, then deleted. That's why the only values left are the hh:00:00 (0 minutes). Any ways around this? I think I can make it >= or <= to get rid of this problem.

EDIT2:

I've edited the code to this:

r = Cells.SpecialCells(xlCellTypeLastCell).Row
With ActiveSheet
    For i = r To 1 Step -1
        If .Range("B" & i) <> "" Then
            h = VBA.Hour(.Range("B" & i))
            If h < 7 Or h >= 19 Then .Rows(i).EntireRow.Delete
            If h >= 10 And h < 16 Then .Rows(i).EntireRow.Delete
        End If
    Next
End With
Application.ScreenUpdating = True

For some reason it deletes all time values after 10am. All I get is 7am-10am.

EDIT3: Fixed! For some reason my column had not all the values converted to time format and that's why the >10am kept getting deleted.

Thanks for all the help.

Sorry for the mistake
Use this instead as it will delete a record that is for example 7:05 PM
The old one (After your modification) will only consider the hour value and disregard the minutes.

Sub DeleteTimes()
Application.ScreenUpdating = False
ThisWorkbook.Save
Dim h As Double, r As Integer, i As Integer
r = Cells.SpecialCells(xlCellTypeLastCell).Row
With ActiveSheet
    For i = r To 1 Step -1
        If .Range("B" & i) <> "" Then
            h = VBA.Hour(.Range("B" & i)) + (VBA.Minute(.Range("B" & i)) / 60)
            If h < 7 Or h > 19 Then .Rows(i).EntireRow.Delete
            If h > 10 And h < 16 Then .Rows(i).EntireRow.Delete
        End If
    Next
End With
Application.ScreenUpdating = True
End Sub