Sub SupprimerLignes()
Application.ScreenUpdating = False
With [B6].CurrentRegion
.Columns(2).Insert xlToRight
.Columns(2) = "=1/(RC[-1]<>1)"
.Columns(2) = .Columns(2).Value 'supprime les formules
.Sort .Columns(2), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
On Error Resume Next 'si aucune SpecialCell
Intersect(.Columns(2).SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells).Delete xlUp
.Columns(2).Delete xlToLeft
End With
End Sub