Looping through cells and deleting the entire row if the cell has a range of dates

[excelnewb2020]

I am having an issue writing a script that will loop through each cell and delete each row that contains a cell with a range of dates. For example, the below table should keep all of the rows that have a single date (i.e. 2021-01-12) while deleting all rows that contain a range (i.e. 2021-01-01 - 2021-01-02).

The script I have written so far does not work:

Sub test ()
Dim lastRow2 as Long
lastRow2 = Range("A" & Rows.Count).End(xlUp).Row
For Each c In Range("A2", "A" & lastRow2)
If Len(c) > 10 Then c.EntireRow.Delete
Next c
End sub

2021-01-12	OtherData
2021-01-12	OtherData
2021-01-12	OtherData
2021-01-12	OtherData
2021-01-12	OtherData
2021-01-12	OtherData
2021-01-12	OtherData
2021-01-01 - 2021-01-02	OtherData
2021-01-01 - 2021-01-02	OtherData
2021-01-01 - 2021-01-02	OtherData
2021-01-01 - 2021-01-02	OtherData
2021-01-01 - 2021-01-02	OtherData
2021-01-01 - 2021-01-02	OtherData
2021-01-01 - 2021-01-02	OtherData

 

[Norie]

When deleting you should loop from the bottom to the top.

Sub test ()
Dim lastRow2 as Long

    lastRow2 = Range("A" & Rows.Count).End(xlUp).Row
    For idx = lastRow2 To 2 Step -1
        If Len(Range("A" & idx) > 10 Then Rows(idx).Delete
    Next idx

End sub

 

[Fluff]

Hi & welcome to MrExcel.
Another option is to delete all the rows in one go, like

Sub test()
   Dim lastRow2 As Long
   Dim c As Range, Rng As Range

   lastRow2 = Range("A" & Rows.Count).End(xlUp).Row
   For Each c In Range("A2", "A" & lastRow2)
      If Len(c) > 10 Then
         If Rng Is Nothing Then Set Rng = c Else Set Rng = Union(Rng, c)
      End If
   Next c
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

 

[excelnewb2020]

Thanks it works! Although the script takes quite awhile to execute (might be something unrelated though).

 

[Fluff]

Which code are you referring to?

 

[excelnewb2020]

Hi & welcome to MrExcel.
Another option is to delete all the rows in one go, like

Sub test()
   Dim lastRow2 As Long
   Dim c As Range, Rng As Range

   lastRow2 = Range("A" & Rows.Count).End(xlUp).Row
   For Each c In Range("A2", "A" & lastRow2)
      If Len(c) > 10 Then
         If Rng Is Nothing Then Set Rng = c Else Set Rng = Union(Rng, c)
      End If
   Next c
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

This one is amazing; much faster! Thank you so much for the help folks, I really appreciate it.

 

[Fluff]

Glad we could help & thanks for the feedback.