CODEWITHSUNDEEP
vbaexcel
isic5
isic5

Reputation: 191

Check range of Columns in each row and delete row if all columns have no values in them

I want to create a macro that goes through each row in my sheet and checks columns F:I if they have values in them. If ALL columns are empty then the current row should be deleted.

I tried recycling some code but when I run it, all rows in that sheet get deleted for some reason.

This is the code I have so far:

Sub DeleteRowBasedOnCriteria()

Dim RowToTest As Long
Dim noValues As Range, MyRange As Range

For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1

Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)

On Error Resume Next
Set noValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0

If noValues Is Nothing Then
    Rows(RowToTest).EntireRow.Delete

End If

Next RowToTest


End Sub

Upvotes: 0

Views: 81

Answers (3)

QHarr
QHarr

Reputation: 84465

You can do this way (it is more efficient to delete rows all in one go using Union):

Option Explicit
Public Sub DeleteRows()
    Dim unionRng As Range, rng As Range
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet name
        For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)) '<== Column C cells to loop over from row 2 to last row
            If Application.WorksheetFunction.CountBlank(rng.Offset(, 3).Resize(1, 4)) = 4 Then   'rng.Offset(, 3).Resize(1, 4)) limits to column F:I. CountBlank function will return number of blanks. If 4 then all  F:I columns in that row  are blank
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(rng, unionRng) 'gather qualifying ranges into union range object
                Else
                    Set unionRng = rng
                End If
            End If
        Next rng
    End With
    If Not unionRng Is Nothing Then unionRng.EntireRow.Delete '<== Delete union range object if contains items
    Application.ScreenUpdating = True
End Sub

Or this way:

Option Explicit

Public Sub DeleteRows()
    Dim unionRng As Range, rng As Range
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)).Offset(, 3).Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 1, 4).Rows
            On Error GoTo NextLine
            If rng.SpecialCells(xlCellTypeBlanks).Count = 4 Then
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(rng, unionRng)
                Else
                    Set unionRng = rng
                End If
            End If
NextLine:
        Next rng
    End With
    If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

Upvotes: 2

cybernetic.nomad
cybernetic.nomad

Reputation: 6368

Try the following:

On Error Resume Next
Set noValues = Intersect(myRange.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0

If noValues Is Nothing Then
    Rows(RowToTest).EntireRow.Delete
Else
    Set noValues = Nothing
End If

Upvotes: 0

BigBen
BigBen

Reputation: 50008

Try using WorksheetFunction.CountA.

Option Explicit

Sub DeleteRowBasedOnCriteria()

Dim RowToTest As Long
Dim MyRange As Range

For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
    Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)

    If WorksheetFunction.CountA(MyRange) = 0 Then
        MyRange.EntireRow.Delete
    End If
Next RowToTest

End Sub

Upvotes: 1

Related Questions