Supprimer lignes avec toutes cellules = 0

Dim i As Integer
i = 1
While Not IsEmpty(Cells(i, 1))
  Dim asupprimer As Boolean
  asupprimer = True
  Dim j As Integer
  j = 1
  While asupprimer And Not IsEmpty(Cells(i, j))
    asupprimer = (Cells(i, j).Value = 0)
    j = j + 4
  Wend
  If asupprimer Then
     Cells(i, 1).EntireRow.Delete
  Else
    i = i + 1
  End If
Wend

Sub SuppLigne()
Dim Lig As Long, Col As Integer
Dim Compter As Integer
    For Lig = 1873 To 9 Step -1
        For Col = 2 To 7
            If Cells(Lig, Col) <> 0 Then Exit For
        Next Col
        If Col = 8 Then Compter = Compter + 1 Else Compter = 0
        If Compter = 16 Then
            Rows(Lig & ":" & Lig + 15).Delete
            Compter = 0
        End If
    Next Lig
End Sub