Deleting rows in a range where cell has specific value - excel

Question

I'm trying to delete any rows in the range "Y3:Y50" where in column "Y", the value is "0".
Dim aRange As Range, aRow As Range, aCell As Range
Set aRange = Range("Y3:Y50")
For Each aRow In aRange.Rows
For Each aCell In aRow.Cells
If aCell.Value = "0" Then
aRow.EntireRow.Delete
Exit For
End If
Next aCell
Next aRow
It is deleting some but not all the rows it should.
The alternative is to delete rows where there is no data in column "A". I feel that would probably be a cleaner option in case I have a row where 0 is the correct value in the future.
Full macro below.
Sub SubbyRunsheet()
Dim rng As Range, URng As Range, cel As Range
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Runsheet")
Application.ScreenUpdating = False
'Clean up SOR sheet
Sheets("SOR").Activate
With ActiveSheet
.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "<>" & Worksheets("Runsheet").Range("E1")
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
'Clean up the runsheet
Sheets("Runsheet").Activate
ActiveSheet.Range("A:A").Delete
ActiveSheet.Cells.Select
Cells.WrapText = False
Selection.EntireColumn.AutoFit
'VBasic's code
Const Addr As String = "Y3:Y50"
Const Criteria As Variant = 0
Set rng = ws.Range(Addr)
For Each cel In rng.Cells
If cel.Value = Criteria Then GoSub collectCells
Next cel
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
Cells(1, 1).Select
Cells.WrapText = True
ActiveSheet.Range("A2:Y100").RowHeight = 15
Application.DisplayAlerts = False
Worksheets("Reference").Delete
Worksheets("Format Helper").Delete
Worksheets("Airtable Upload").Delete
Worksheets("Formula Sheet").Delete
Application.DisplayAlerts = True
WeekEnding = Format(ActiveSheet.Range("B3").Value, "yyyymmdd")
ActiveWorkbook.SaveAs Filename:="C&I Subcontractor Weekly Runsheet - " & Worksheets("Runsheet").Range("D1") & " WE " & WeekEnding
Application.ScreenUpdating = True
End Sub

Answer 1

Delete Rows With Criteria
Option Explicit
Sub deleteRowsY()
' Constants
Const Addr As String = "Y3:Y50"
Const Criteria As Variant = 0
' If this is happening in the workbook containing this code,
' then use 'Set wb = ThisWorkbook' instead.
Dim wb As Workbook: Set wb = ActiveWorkbook
' The worksheet is better defined by its name,
' e.g. Set ws = wb.Worksheets("Sheet1")
Dim ws As Worksheet: Set ws = wb.ActiveSheet
' Define Column Range.
Dim rng As Range: Set rng = ws.Range(Addr)
' Loop through each cell in Column Range.
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If cel.Value = Criteria Then GoSub collectCells
Next cel
' Test with hiding, you cannot undo the deletion.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
' When ready, outcomment the previous and uncomment the following line.
'If Not URng Is Nothing Then URng.EntireRow.Delete
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub
Sub deleteRowsA()
' Constants
Const FirstRow As Long = 3
Const tgtCol As Variant = "A" ' e.g. 1 or "A"
Const Criteria As Variant = Empty
' If this is happening in the workbook containing this code,
' then use 'Set wb = ThisWorkbook' instead.
Dim wb As Workbook: Set wb = ActiveWorkbook
' The worksheet is better defined by its name,
' e.g. Set ws = wb.Worksheets("Sheet1")
Dim ws As Worksheet: Set ws = wb.ActiveSheet
' Define Column Range.
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, tgtCol).End(xlUp).Row
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, tgtCol), ws.Cells(LastRow, tgtCol))
' Loop through each cell in Column Range.
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If cel.Value = Criteria Then GoSub collectCells
Next cel
' Test with hiding, you cannot undo the deletion.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
' When ready, outcomment the previous and uncomment the following line.
'If Not URng Is Nothing Then URng.EntireRow.Delete
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub
EDIT:
Option Explicit
Sub deleteY(Sheet As Worksheet, RangeAddress As String, Criteria As Variant)
' Define Column Range.
Dim rng As Range: Set rng = Sheet.Range(RangeAddress)
' Loop through each cell in Column Range.
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If cel.Value = Criteria Then GoSub collectCells
Next cel
' Test with hiding, you cannot undo the deletion.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
' When ready, outcomment the previous and uncomment the following line.
'If Not URng Is Nothing Then URng.EntireRow.Delete
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub
Sub delY()
' Constants
Const ColumnAddress As String = "Y3:Y50"
Const Criteria As Variant = 0
' Define worksheet.
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
deleteY ws, ColumnAddress, Criteria
End Sub
Sub deleteA(Sheet As Worksheet, _
FirstRow As Long, _
ColumnID As Variant, _
Criteria As Variant)
' Define Column Range.
Dim LastRow As Long
LastRow = Sheet.Cells(Sheet.Rows.Count, ColumnID).End(xlUp).Row
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, ColumnID), _
ws.Cells(LastRow, ColumnID))
' Loop through each cell in Column Range.
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If cel.Value = Criteria Then GoSub collectCells
Next cel
' Test with hiding, you cannot undo the deletion.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
' When ready, outcomment the previous and uncomment the following line.
'If Not URng Is Nothing Then URng.EntireRow.Delete
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub
Sub delA()
' Constants
Const FirstRow As Long = 3
Const ColumnID As Variant = "A" ' e.g. 1 or "A"
Const Criteria As Variant = Empty
' Define worksheet.
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
deleteA ws, FirstRow, ColumnID, Criteria
End Sub
Your Final Solution
Option Explicit
Sub SubbyRunsheet()
Const RangeAddress As String = "Y3:Y50"
Const Criteria As Variant = 0
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Runsheet")
Application.ScreenUpdating = False
'Clean up SOR
Sheets("SOR").Activate
With ActiveSheet
.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "<>" & Worksheets("Runsheet").Range("E1")
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
'Clean up Runsheet
ws.Activate
ActiveSheet.Range("A:A").Delete
ActiveSheet.Cells.Select
Cells.WrapText = False
Selection.EntireColumn.AutoFit
' Delete rows containing 0-s in Y-column of Runsheet
deleteY ws, RangeAddress, Criteria
Cells(1, 1).Select
Cells.WrapText = True
ActiveSheet.Range("A2:Y100").RowHeight = 15
Application.DisplayAlerts = False
Worksheets("Reference").Delete
Worksheets("Format Helper").Delete
Worksheets("Airtable Upload").Delete
Worksheets("Formula Sheet").Delete
Application.DisplayAlerts = True
WeekEnding = Format(ActiveSheet.Range("B3").Value, "yyyymmdd")
ActiveWorkbook.SaveAs Filename:="C&I Subcontractor Weekly Runsheet - " _
& ws.Range("D1") & " WE " & WeekEnding
Application.ScreenUpdating = True
End Sub
Sub deleteY(Sheet As Worksheet, RangeAddress As String, Criteria As Variant)
' Define Column Range.
Dim rng As Range: Set rng = Sheet.Range(RangeAddress)
' Loop through each cell in Column Range.
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If cel.Value = Criteria Then GoSub collectCells
Next cel
' Test with hiding, you cannot undo the deletion.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
' When ready, outcomment the previous and uncomment the following line.
'If Not URng Is Nothing Then URng.EntireRow.Delete
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub