Проверьте диапазон столбцов в каждой строке и удалите строку, если во всех столбцах нет значений

Question

Я хочу создать макрос, который проходит через каждую строку в моем листе и проверяет столбцы F: I, если в них есть значения. Если ВСЕ столбцы пусты, то текущая строка должна быть удалена.

Я пытался переработать некоторый код, но когда я его запускаю, все строки на этом листе по какой-то причине удаляются.

Это код, который у меня есть:

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

Answer 1

Вы можете сделать это (более эффективно удалять все строки за один раз, используя 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

Или вот так:

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

Answer 2

Попробуйте следующее:

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

Answer 3

Попробуйте использовать 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