Code:Sub DeleteData() Const FORMULA_DELETE As String = _ "=OR($D3=MIN(IF(($A$3:$A$<lastrow>=A3)*($E$3:$E$<lastrow>=""In""),$D$3:$D$<lastrow>))," & _ "$D3=MAX(IF(($A$3:$A$<lastrow>=A3)*($E$3:$E$<lastrow>=""Out""),$D$3:$D$<lastrow>)))" Dim rng As Range Dim lastrow As Long Dim i As Long With ActiveSheet lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row .Columns("I").Insert .Rows(1).Insert .Range("I1:I2").Value = Array("tmp", "TRUE") .Range("I3").FormulaArray = Replace(FORMULA_DELETE, "<lastrow>", lastrow + 1) .Range("I3").AutoFill .Range("I3").Resize(lastrow - 1) Set rng = .Range("I1").Resize(lastrow) rng.AutoFilter 1, "=FALSE" On Error Resume Next Set rng = rng.SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not rng Is Nothing Then rng.EntireRow.Delete End If .Columns("I").Delete End With End Sub
Bookmarks