如果在某个范围内填充了空白和零，则删除行

Question

我有一份报告，我需要删除单元格中没有数据的行或范围列 C 到 O 中为零的行。

我的这段代码几乎完美地完成了，但我发现了一个致命的逻辑缺陷。如果该行的正负值总和为零，它将被删除，而我仍然需要保留该行。

我非常感谢这个网站的帮助，因为我已经能够真正自动化我的许多报告并帮助其他部门的人！你们真棒！谢谢！

Dim rw As Long, i As Long
rw = Cells(Rows.Count, 1).End(xlUp).Row
For i = rw To 6 Step -1
If Application.Sum(Cells(i, 3).Resize(1, 17)) = 0 Then
Rows(i).Delete
End If
Next

Answer 1

不是检查 SUM，而是遍历每个单元格并检查其是否有效。

为了更好地解释这一点，我将为您使用伪代码：

1. 创建一个标志变量并将其设置为 false
2. 创建一个循环检查一行中的每个单元格
3. 如果找到有效数字，则将该标志设置为 true
4. 在移动到下一个单元格之前，检查您的标志是否仍然为假
5. 如果您的标志为假 -> 继续下一个单元格
6. 循环到行中所有单元格的末尾

伪代码变成粗代码

Dim rw As Long, i As Long
Dim rng As Range
Dim validRow As Boolean
validRow = false

rw = Cells(Rows.Count, 1).End(xlUp).Row

For i = rw To 6 Step -1
    Set rng = (Cells(i, 3).Resize(1, 17))
    For Each cell In rng
         If Not IsEmpty(cell) Then
            If cell.value <> 0 Then
               validRow = true
            End If
         End If
         If validRow = true Then
        Exit For
         End If
    Next cell
    If validRow = false Then
        Rows(i).Delete
    End If
    validRow = false
Next

[@LL 编辑：将 >0 更改为 0 也寻找任何不同于零的值，以说明仅填充负值的行]

Answer 2

首先，我猜Resize 有错误 - 它应该是 13 - 而不是 17。 其次，如果要删除的数据很多，可以使用AutoFilter。

第一种方式。

修改你的代码：

Sub FFF()
    Dim rw As Long, i As Long, cntZeroes%, cntEmpty%
    rw = Cells(Rows.Count, 1).End(xlUp).Row
    For i = rw To 6 Step -1
        With Cells(i, 3).Resize(, 13)
            cntZeroes = Application.CountIf(.Cells, 0)
            cntEmpty = Application.CountIf(.Cells, vbNullString)
            If cntZeroes = 13 Or cntEmpty = 13 Then Rows(i).Delete
        End With
    Next
End Sub

第二种方式。

使用辅助列 P（因为它位于 O 旁边）和 AutoFilter。比较复杂，但比逐行删除要快：

Sub FFF2()
    Dim rw As Long, i As Long, cntZeroes%, cntEmpty%
    rw = Cells(Rows.Count, 1).End(xlUp).Row
    For i = rw To 6 Step -1
        With Cells(i, 3).Resize(, 13)
            cntZeroes = Application.CountIf(.Cells, 0)
            cntEmpty = Application.CountIf(.Cells, vbNullString)
            If cntZeroes = 13 Or cntEmpty = 13 Then
                Cells(i, "P") = 1
            End If
        End With
    Next
    With Rows(5)
        .AutoFilter Field:=16, Criteria1:=1
        On Error Resume Next
        With .Parent.AutoFilter.Range
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        On Error GoTo 0
        .Parent.AutoFilterMode = False
    End With

End Sub

Answer 3

将空单元格视为零！？

在开发用于删除行和/或列的代码时，最好使用 Hidden 属性而不是 Delete 方法，这样就不会删除错误的内容。因此，我会得出结论，以这种方式发布它也是一种好习惯。
您必须将 cBlnDEL 更改为 True 以启用 DELETE 功能，我建议您仅在检查了启用 HIDDEN 功能的代码后才执行此操作.

“快速”联合版本

'*******************************************************************************
' Purpose:    Deletes or hides empty rows, and rows containing zero (0) in     *
'             a specified range, in the ActiveSheet (of the ActiveWorkbook).   *
'*******************************************************************************
Sub DeleteBlankAndZeroRows()

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  Const Col1 As Integer = 3         ' First Column of Source Range
  Const Col2 As Integer = 13        ' Last Column of Source Range
  Const Row1 As Integer = 6         ' First Row of Source Range
  Const cBlnDEL As Boolean = False  ' If True, Delete. If False, Hide.

  Dim rng As Range                  ' Check Range
  Dim rngU As Range                 ' Target Union Range

  Dim Row2 As Long                  ' Last Row of Source Range
  Dim i As Long                     ' Source Range Rows Counter
  Dim j As Long                     ' Source Range Columns Counter
  Dim k As Long                     ' Deleted Rows Counter
  Dim strMsg As String              ' Msgbox Text

  On Error GoTo ErrorHandler

  With ActiveWorkbook.ActiveSheet ' A reminder of where this is happening.
    ' Calculate last row of Source Range.
    Row2 = .Cells(.Rows.Count, 1).End(xlUp).Row
    ' Set bogus reference to "aquire range level" (Parent).
    Set rng = .Cells(1, 1)
  End With

  ' Loop through each row in Source Range.
  For i = Row1 To Row2

    ' Calculate the Check Range for current row in Source Range.
    Set rng = rng.Parent.Cells(i, Col1).Resize(1, Col2)

    ' If the cell at the intersection of column Col1 and the current row
    ' is 0, add it to the Target Union Range.
    ' Note: Unexpectedly, the value of an empty cell is treated as 0 here.

    ' Loop through each cell of the (one-row) Check Range.
    For j = 1 To rng.Columns.Count

      If rng.Cells(1, j).Value = 0 Then ' If 0 is found.
        k = k + 1                         ' Count to be deleted rows.
        If Not rngU Is Nothing Then       ' There already is a range in rngU.
          Set rngU = Union(rngU, rng.Cells(1, 1)) ' Add another.
         Else                             ' There is no range in rngU.
          Set rngU = rng.Cells(1, 1)              ' Add one.
        End If
        Exit For
'         Else                            ' If 0 is NOT found.
      End If

    Next ' (Cell in (one-row) Check Range)

  Next   ' (Row in Source Range)

  ' Note: If no 0 was found, the Target Union Range does NOT contain a range.

  If Not rngU Is Nothing Then ' Target Union Range contains range(s).
    If cBlnDEL Then ' DELETE is active. Delete Target Union Range.
      strMsg = "DeleteBlankAndZeroRows successfully deleted " & k _
          & " rows in " & rngU.Areas.Count & " areas."
      rngU.Rows.EntireRow.Delete
     Else           ' HIDDEN is active. Hide Target Union Range.
      strMsg = "DeleteBlankAndZeroRows has successfully hidden " & k _
          & " rows in " & rngU.Areas.Count & " areas."
      rngU.Rows.EntireRow.Hidden = True
    End If
   Else                       ' Target Union Range does NOT contain range(s).
    strMsg = "You may have used the DELETE feature of " _
        & "DeleteBlankAndZeroRows recently, because " _
        & " it could not find any zeros. Nothing deleted."
  End If

ProcedureExit:

  Set rngU = Nothing
  Set rng = Nothing

  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

  MsgBox strMsg

Exit Sub

ErrorHandler:
  strMsg = "An unexpected error occurred. Error: " & Err.Number & vbCr _
      & Err.Description
  GoTo ProcedureExit

End Sub
'*******************************************************************************

前面的代码隐藏或删除了如图所示黄色区域有红色单元格的每一行。

特殊版本（不推荐）

Sub DelBlankAndZeroRowsDontKnowHowIGotOutOfMyBedThisAfternoonVersion()
  Dim rw As Long, i As Long, j As Long
  Dim rng As Range, rngU As Range
    rw = Cells(Rows.Count, 1).End(xlUp).Row
    For i = rw To 6 Step -1
      Set rng = Cells(i, 3).Resize(1, 13)
      For j = 1 To rng.Columns.Count
        If rng.Cells(1, j).Value = 0 Then
          If Not rngU Is Nothing Then
            Set rngU = Union(rng.Cells(1, 1), rngU)
           Else
            Set rngU = rng.Cells(1, j)
          End If
        End If
      Next
    Next
    rngU.Rows.Hidden = True
  Set rngU = Nothing
  Set rng = Nothing
End Sub

Sub DelBlankAndZeroRowsThinkImGonnaStayInBedTodayVersion()
Dim rw As Long, i As Long, j As Long
Dim rng As Range, rngU As Range
rw = Cells(Rows.Count, 1).End(xlUp).Row
For i = rw To 6 Step -1
Set rng = Cells(i, 3).Resize(1, 13)
For j = 1 To rng.Columns.Count
If rng.Cells(1, j).Value = 0 Then
If Not rngU Is Nothing Then
Set rngU = Union(rng.Cells(1, 1), rngU)
Else
Set rngU = rng.Cells(1, j)
End If
End If
Next
Next
rngU.Rows.Hidden = True
Set rngU = Nothing
Set rng = Nothing
End Sub

Sub DelBlankAndZeroRowsNeverGonnaGetUpVersion()
Dim rw As Long, i As Long, j As Long, rng As Range, rngU As Range
rw = Cells(Rows.Count, 1).End(xlUp).Row: For i = rw To 6 Step -1
Set rng = Cells(i, 3).Resize(1, 13): For j = 1 To rng.Columns.Count
If rng.Cells(1, j).Value = 0 Then
If Not rngU Is Nothing Then
Set rngU = Union(rng.Cells(1, 1), rngU)
Else: Set rngU = rng.Cells(1, j): End If: End If: Next: Next
rngU.Rows.Hidden = True: Set rngU = Nothing: Set rng = Nothing: End Sub