Delete entirerow if cellvalue in column A has "xxxx" as year

[Eyeson15]

Please take me out of my misery.
I think I'm going insane from google search overload.

I have a workbook with 5000+ entries. It has dates in the format (dd.mm.yy) in Column A.

All I need to do is delete ALL the rows that are not between 2005 and 2010 (inclusive both years)

For example:

(1) 22.02.14
(2) 01.01.07
(3) 02.12.01

So, Rows 1 and 3 would be deleted and 01.01.07 is kept because it is between 2005 and 2010.

Please help me, I got over 6 workbooks to do this and really can't do this manually.

Below is the code I sort of made. Doesn't work ofcourse but brilliant code for crashing computers.

James

Sub DeleteRows()
    
    Dim i As Long
    Dim st As Long
    Dim en As Long
    Dim test As Long

    'Set ranges to four digit year code'
    st = 2005
    en = 2010

    For i = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    
    test = Val(WorksheetFunction.Text(ActiveSheet.Range("A" & i).Value, "yyyy"))
    If test < st Or test > en Then
    ActiveSheet.Range("A" & i).EntireRow.Delete
    End If
    Next i
    
End Sub

 

[Eyeson15]

You have text strings, not real Excel dates.

Try this:

Sub DeleteRows()
    
    Dim cll As Range
    Dim Rng2Del As Range

    Const st = 5
    Const en = 10

    Application.ScreenUpdating = False
    For Each cll In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If (CByte(Right(cll.Value, 2)) < st) Or (CByte(Right(cll.Value, 2)) > en) Then
            If Rng2Del Is Nothing Then
                Set Rng2Del = cll
            Else
                Set Rng2Del = Application.Union(Rng2Del, cll)
            End If
        End If
    Next cll
    Rng2Del.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

Hi Tetra

Thank you so much for your continued help.
It still shows debug error at "If (CByte(Right(cll.Value, 2)) < st) Or (CByte(Right(cll.Value, 2)) > en) Then",
but I am very grateful for the time you have invested in trying to help.

I have tried changing the dates to proper formats excel has; short and long dates and then tried both your codes but still mismatch error.

Not sure how I can fix this.

James

 

[Eyeson15]

Thanks i understand the or option from your code

my condensed code is

Sub DeleteRows()
    Application.ScreenUpdating = False
    Dim i As Long
    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    If Year(Range("A" & i)) < "2005" Or Year(Range("A" & i)) > "2010" Then
    ActiveSheet.Range("A" & i).EntireRow.Delete
    End If
    Next i
    Application.ScreenUpdating = True
End Sub

Thank you very much.
I tinkered around with your code.
It works well except that at the very end it shows a 'mismatch' error but that is after all the necessary rows have been deleted.
I am assuming that your code checks to see if there are any more rows to delete and when it's "none left" it gives that error message - I think.
So I placed
"On Error Resume Next" before all your code to disable that error message.
Works!

I am very grateful.

P.S (EDIT) OH MY GOD! I found the problem. The very first row at top had text!! There is no error message with your code.

Regards,

James

 

[Eyeson15]

See if this works for you:

Sub DeleteRows()
    
    Dim cll As Range
    Dim Rng2Del As Range

    'Set ranges to four digit year code'
    Const st = 2005
    Const en = 2010

    Application.ScreenUpdating = False
    For Each cll In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If (Year(cll.Value) < st) Or (Year(cll.Value) > en) Then
            If Rng2Del Is Nothing Then
                Set Rng2Del = cll
            Else
                Set Rng2Del = Application.Union(Rng2Del, cll)
            End If
        End If
    Next cll
    Rng2Del.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

OMG! Your code works very well!
I found the problem. The very first row at the top had text. After I deleted the first row and only the data left, your code works flawlessly.
And it is much faster as you mentioned.
I will think about you before I sleep tonight.
Thank you soooooooooooooooooooooooooo much.

Kindest Regards,

James

 

[Rick Rothstein]

OMG! Your code works very well!
I found the problem. The very first row at the top had text. After I deleted the first row and only the data left, your code works flawlessly.
And it is much faster as you mentioned.

The code below should be faster than the code Tetra201 posted, but whether you see the time difference depends on how much data you have. I do know the Tetra201's could would more than likely fail with a huge amount of data due to the repeated Union function calls. I tested both codes with 500,000 rows of data, 6 columns wide (all constants, no formulas) and gave up on Tetra201's code after 10 minutes (not sure if it would ever have come back from its "Not Responding" state or not)... the code below completed the task (deleting 356,688 rows of data) in 26.3 seconds. Here is the code...

[table="width: 500"]
[tr]
	[td]Sub DeleteRows()
  Dim LastRow As Long, UnusedCol As Long, Before As Long, After As Long
  Before = 2005
  After = 2010
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  UnusedCol = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
  Application.ScreenUpdating = False
  Cells(1, UnusedCol).Resize(LastRow) = Evaluate("ROW(1:" & LastRow & ")")
  Columns("A:A").AutoFilter 1, "<1/1/" & Before, xlOr, ">12/31/" & After
  ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.ClearContents
  Columns("A:A").AutoFilter
  Columns("A:A").Resize(LastRow, UnusedCol).Cells.Sort Cells(1, UnusedCol), xlAscending
  Columns(UnusedCol).Clear
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

 

[Eyeson15]

The code below should be faster than the code Tetra201 posted, but whether you see the time difference depends on how much data you have. I do know the Tetra201's could would more than likely fail with a huge amount of data due to the repeated Union function calls. I tested both codes with 500,000 rows of data, 6 columns wide (all constants, no formulas) and gave up on Tetra201's code after 10 minutes (not sure if it would ever have come back from its "Not Responding" state or not)... the code below completed the task (deleting 356,688 rows of data) in 26.3 seconds. Here is the code...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub DeleteRows()
  Dim LastRow As Long, UnusedCol As Long, Before As Long, After As Long
  Before = 2005
  After = 2010
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  UnusedCol = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
  Application.ScreenUpdating = False
  Cells(1, UnusedCol).Resize(LastRow) = Evaluate("ROW(1:" & LastRow & ")")
  Columns("A:A").AutoFilter 1, "<1/1/" & Before, xlOr, ">12/31/" & After
  ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.ClearContents
  Columns("A:A").AutoFilter
  Columns("A:A").Resize(LastRow, UnusedCol).Cells.Sort Cells(1, UnusedCol), xlAscending
  Columns(UnusedCol).Clear
  Application.ScreenUpdating = True
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Hello Rick!

Thank you so much for your help.
They say you are Excel god so I will erect a shrine in your honour.
Jokes aside, I greatly appreciate your help.

Your code works flawlessly and yes, it is faster.

Kindest Regards,

James

 

[Rick Rothstein]

Hello Rick!

Thank you so much for your help.

You are quite welcome. By the way, I forgot to mention that my code assumes you have a header row, so if it is still deleted, put it back.

They say you are Excel god so I will erect a shrine in your honour.

I am pretty sure that no one says that... or at least they shouldn't.

Your code works flawlessly and yes, it is faster.

Just wondering... about how many rows of data did you have when you tested my code?

 

[Eyeson15]

You are quite welcome. By the way, I forgot to mention that my code assumes you have a header row, so if it is still deleted, put it back.




I am pretty sure that no one says that... or at least they shouldn't.




Just wondering... about how many rows of data did you have when you tested my code?

Yes, I do have header row but your code doesn't delete it which is GREAT.

I have about 10 workbooks ranging between 10000-30000 entries(rows)

Works flawlessly. Can't thank you enough sir.

James

 

[Eyeson15]

Actually, I changed this part,

Cells(1, UnusedCol).Resize(LastRow) = Evaluate("ROW(1:" & LastRow & ")")

ROW(1 to ROW(2 so the header row doesn't get deleted. To avoid confusion for anyone.

 

[Rick Rothstein]

Actually, I changed this part,

Cells(1, UnusedCol).Resize(LastRow) = Evaluate("ROW(1:" & LastRow & ")")

ROW(1 to ROW(2 so the header row doesn't get deleted. To avoid confusion for anyone.

The code I posted works perfectly with the header... as a matter of fact, it requires the header in order to work. The reason is the way AutoFilter works... without the header, it exempts the first row of data from being hidden (if its date is such that it should be hidden) because that is the row it puts the dropdown triangles in. I haven't looked at the ramifications of your change, but I am sure that my original code works correctly with a header row, it requires no change.

 

[Peter_SSs]

I tested both codes with 500,000 rows of data, 6 columns wide (all constants, no formulas) ... the code below completed the task (deleting 356,688 rows of data) in 26.3 seconds.

As it turns out the OP doesn't have that much data so the difference will be less, but I also tested with similar data and on my (quite old) machine the post #14 code took a little longer at about 40 seconds.
The code below took 4 seconds on the same data, so may also be worth considering if speed is an issue.

Sub Del_Date_Rows()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long, lBefore As Long, lAfter As Long
  
  lBefore = DateSerial(2005, 1, 1)
  lAfter = DateSerial(2010, 12, 31)
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Formula
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) < lBefore Or a(i, 1) > lAfter Then   '<- Could be split to make a bit faster
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

If required, this code could be sped up slightly as well by splitting the commented line into 2 separate comparisons.
Post back if you need that tiny bit of extra speed.