Delete entire row if cell contains todays date

Question

I am trying to write a macro in Excel that will perform a number of tasks, with the final task being to delete an entire row if the current date is in column A.

Here is what I have recorded. I tried using other scripts I've found online to complete the final task, but it is not being completed. I am not receiving any type of error message.

Sub NCR()
'
' NCR Macro
'

'
Cells.Select
With Selection
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("H:K").Select
Selection.Delete Shift:=xlToLeft
Rows("2:1048576").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range( _
    "E2:E1076"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A2:AI1076")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$84").AutoFilter Field:=5, Criteria1:= _
    "In Progress"
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells.Select
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Cells.EntireColumn.AutoFit
Rows("2:1048576").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range( _
    "A2:A1048501"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A2:AI1048501")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Range("B14").Select
  With Range("A2:A500" & lastrow)
.AutoFilter 1, "=" & CLng(Date)
.Offset(1).EntireRow.Delete
.AutoFilter
End With
End Sub

I am by no means an expert in recording Macros, but everything works fine until I get to "Range B14 Select." AFter then, the script stops without any error message.

What am I doing wrong? How can this be fixed?

`Range("A2:A500" & lastrow)` looks off. You need to [find the lastrow first](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba), then use `Range("A2:A" & lastrow)`. — BigBen, Apr 06 '21 at 16:00
Please read Minimal, Complete, and Verifiable example: **https://stackoverflow.com/help/mcve** — StureS, Apr 06 '21 at 16:25

score 0 · Answer 1 · answered Apr 06 '21 at 17:42

0

Replace

With Range("A2:A500" & lastrow)
.AutoFilter 1, "=" & CLng(Date)
.Offset(1).EntireRow.Delete
.AutoFilter
End With

with

Dim i
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    If Cells(i, 1) = Date Then Rows(i).Delete
Next

answered Apr 06 '21 at 17:42

CDP1802

13,871
2
7
17

Delete entire row if cell contains todays date

1 Answers1