DELETE CELL OF ZERO VALUE

[K]

Hi all, I want macro that if any cell in range L2 to last value cell
in column L have zero value then row from column H to M of that cell
should be deleted (Delete Shift:= xlUP)
Please can anybody help.

 

[Norman Jones]

Hi K,

In a standard module, try:


'================>>
Public Sub DeleteRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim rCell As Range
Dim delRng As Range
Dim iRow As Long
Dim CalcMode As Long
Dim ViewMode As Long

Set WB = Workbooks("myBook.xls") '<<===== CHANGE
Set SH = WB.Sheets("Sheet1") '<<===== CHANGE

With SH
iRow = LastRow(SH, .Columns("L:L"))
Set Rng = SH.Range("L1:L" & iRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ActiveWindow
ViewMode = .View
.View = xlNormalView
End With

SH.DisplayPageBreaks = False


For Each rCell In Rng.Cells
rCell.Select
If rCell.Value = 0 Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
Else
'Do nothing
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

ActiveWindow.View = ViewMode

End Sub
'--------------->

Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<================

 

[Mike H]

Hi,

Right click your sheet tab, view code and paste this in and run it

Sub stance()
Dim copyrange As Range
lastrow = Cells(Cells.Rows.Count, "L").End(xlUp).Row
Set myrange = Range("H2:H" & lastrow)
For Each c In myrange
If Not IsEmpty(c.Offset(, 4)) And c.Offset(, 4).Value = 0 Then
If copyrange Is Nothing Then
Set copyrange = c.Resize(, 6)
Else
Set copyrange = Union(copyrange, c.Resize(, 6))
End If
End If
Next

If Not copyrange Is Nothing Then
copyrange.Delete Shift:=xlUp
End If
End Sub

Mike