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

尝试使用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

Answer 3

排序与我自己的代码，但这应该工作。显然，使用工作表的名称更改sheet4

Sub DeleteRowBasedOnCriteria()
    Dim lastRow As Integer
        lastRow = Sheets("Sheet4").Cells.Find(What:="*", _
                After:=Range("A1"), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
for rowNum = lastRow to 1 step -1
    Dim checkRow As String
        checkRow = Sheets("Sheet4").Cells(rowNum, 6) & Sheets("Sheet4").Cells(rowNum, 7) _
        & Sheets("Sheet4").Cells(rowNum, 8) & Sheets("Sheet4").Cells(rowNum, 9)
    If checkRow = "" Then
         Sheets("Sheet4").Rows(rowNum).EntireRow.Delete
        End If
next
End Sub

Answer 4

尝试以下方法：

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

检查每行中列的范围，如果所有列都没有值，则删除行

4 个答案: