Пустые ячейки рассматриваются как нули!?
При разработке кода для удаления строк и / или столбцов рекомендуется использовать свойство Hidden вместо метода Delete, поэтому неправильные вещи не будутудалитьПоэтому я бы пришел к выводу, что хорошей практикой будет также публиковать ее таким образом.
Вам придется изменить cBlnDEL на True, чтобы включить функцию УДАЛИТЬ , которую я бы рекомендовал вамделать только после того, как вы проверили код с активной функцией HIDDEN .
A 'Fast' Union Version
'*******************************************************************************
' 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