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

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. 在移动到下一个单元格之前，请检查您的标志是否仍为false
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。

First way.

改变你的代码：

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

Second way.

使用辅助列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

Empty Cells Treated As Zeros!?

在开发删除行和/或列的代码时，最好使用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