Sub suppr()
Dim r As Range, c As Range, plg As Range
Dim i As Byte
With ActiveSheet.Range("A1").CurrentRegion
For Each r In .Rows
i = 0
For Each c In r.Cells
i = Array(0, i + 1)(-1 * (c = 0))
If i = 3 Then
If plg Is Nothing Then Set plg = r Else Set plg = Union(r, plg)
Exit For
End If
Next c
Next r
If Not plg Is Nothing Then plg.Delete xlShiftUp
End With
End Sub