Streamlining deleting rows containing dates within a range specified by another cell

Question

I delete rows based on the date in a column.

The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.

I'm not sure if this is due to poorly written code or the size of the dataset.

Sub DeleteCurrentPeriod()

    Dim ws As Worksheet

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("Transaction list by date")
    ws.Activate
  
    On Error Resume Next
    ws.ShowAllData
    On Error GoTo 0
  
    'Insert column, autofill formula for range
        
    Sheets("Transaction list by date").Select
    Columns("AR:AR").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("AR2").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
         Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
    
    'Filter on new column for cells matching criteria
    
    ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
  
    'Delete rows with matching criteria
  
    On Error Resume Next
    Application.DisplayAlerts = False
    ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
  
    'Delete added column and remove filter
    
    Columns("AR:AR").Select
    Selection.Delete Shift:=xlToLeft
    On Error Resume Next
    ws.ShowAllData
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    Application.Goto Reference:=Range("A1")
    
End Sub

score 1 · Answer 1 · answered Dec 11 '20 at 18:59

You can give this a try (use F8 key to run it step by step)

Some suggestions:

Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps

Read about avoiding select and activate here

Code:

   Public Sub DeleteCurrentPeriod()
        
        On Error GoTo CleanFail
            
        ' Turn off stuff
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        Dim transactionSheet As Worksheet
        Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
        
        ' Turn off autofilter and show all data
        transactionSheet.AutoFilterMode = False
    
        ' Find last row
        Dim lastRow As Long
        lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
        
        ' Define range to be filtered
        Dim targetRange As Range
        Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
        
        ' Insert column
        transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        
        ' Add formula & calculate
        transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
        Application.Calculate
        
        'Filter on new column for cells matching criteria
        transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
        
        'Delete rows with matching criteria
        transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        
        'Delete added column and remove filter
        transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
    
        ' Remove filter
        transactionSheet.AutoFilterMode = False
        
        'Select A1
        Range("A1").Select
    
    CleanExit:
            ' Turn on stuff again
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            Exit Sub
        
    CleanFail:
            MsgBox "An error occurred:" & Err.Description
            GoTo CleanExit
        
    
    End Sub

Let me know if it works

Hi Ricardo, thanks for your reply. I’ve tried this and it’s still quite slow. Looking at what I’m trying to do I think I could just ignore the insert column with formula section and just use auto filter for the month I’m trying to delete referencing the date in cell G20 in the control tab but I can’t seem to get it to work, please can you show me how to do it? — VBAnewbie, Dec 14 '20 at 12:01
Hi, you'd have to be more specific about what you're trying to accomplish. What column has the date and in what format is the date in G20. Please [edit] your question and add the relevant data. — Ricardo Diaz, Dec 14 '20 at 15:36

score 0 · Answer 2 · answered Dec 11 '20 at 19:13

I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.

'Insert column, autofill formula for range
         Dim x as Long, y, lastrow
         Sheets("Transaction list by date").Select
         
     'Find the last row used
     With Sheets("Transaction list by date")
     lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
     End With 
     
     Columns("AR:AR").Select
     Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
     Range("AR2").Select
     ' Get the constant and perform the comparison, add "Y" to TRUE cells
     x= Worksheets("Control").Cells(20,7).value
     For y = 1 to lastrow
     If Worksheets("Transaction list by date").Cells(y,44)>x then _
     Worksheets("Transaction list by date").Cells(y,44).value = "Y"
     Next y

     'Filter on new column for cells matching criteria

     ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"

   'Delete rows with matching criteria

   On Error Resume Next
   Application.DisplayAlerts = False
     ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
   Application.DisplayAlerts = True
   On Error GoTo 0

   'Delete added column and remove filter

     Columns("AR:AR").Select
     Selection.Delete Shift:=xlToLeft
   On Error Resume Next
     ws.ShowAllData
   On Error GoTo 0


 Application.ScreenUpdating = True
 Application.Goto Reference:=Range("A1")

End Sub

Hi Toby, thanks for your reply. I’ve tried this and it’s still quite slow. Looking at what I’m trying to do I think I could just ignore the insert column with formula section and just use auto filter for the month I’m trying to delete referencing the date in cell G20 in the control tab but I can’t seem to get it to work, please can you show me how to do it? — VBAnewbie, Dec 14 '20 at 12:08
Its slow because you are interacting with the worksheet. What are you currently comparing it to, todays date (ie the date you are running the macro) or another date? — TobyPython, Dec 15 '20 at 00:14

TobyPython · Answer 3 · 2020-12-15T02:20:05.317

Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp

    a = Worksheets("Sheet1").UsedRange
    nr = UBound(a, 1)
    nc = UBound(a, 2)

    ReDim aNew(1 To nr, 1 To nc)
    rNew = 0
    v = Date

    For r = 1 To nr
        tmp = a(r, COMPARE_COL)
        If tmp <> v Then
            rNew = rNew + 1
            For c = 1 To nc
                aNew(rNew, c) = a(r, c)
            Next c
            v = tmp
        End If
    Next r

    Worksheets("Sheet1").UsedRange = aNew

End Sub

This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.

Streamlining deleting rows containing dates within a range specified by another cell

3 Answers3