Sub SupprimerLignes()
Dim i%, ncol%
Application.ScreenUpdating = False
For i = ActiveSheet.Index To Sheets.Count
If TypeName(Sheets(i)) = "Worksheet" Then 's'il y a des feuilles Graphiques
With Sheets(i).UsedRange
ncol = .Columns.Count
If .Columns(ncol).Column < 16 Then ncol = ncol + 16 - .Columns(ncol).Column
With .Columns(ncol + 1) 'colonne auxiliaire
.FormulaR1C1 = "=1/(COUNTA(RC8:RC16)=1)" 'NBVAL
.Value = .Value 'supprime les formules
.EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour grouper et accélérer
On Error Resume Next 'si aucune SpecialCell
.SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
.ClearContents 'RAZ
End With
End With
End If
Next
End Sub