Sub SupprimerLignes()
Dim tablo, i&, j&
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Offset(1) 'saute la ligne des en-têtes
With .Resize(12 * Int(.Rows.Count / 12) + 12) 'multiple de 4 + 8 = 12
.Columns(1).EntireColumn.Insert 'colonne auxiliaire
tablo = .Columns(0) 'matrice, plus rapide
For i = 1 To UBound(tablo) Step 12
For j = i To i + 3
tablo(j, 1) = 1 'repère
Next j, i
With .Columns(0)
.Value = tablo
.EntireRow.Sort .Cells, Header:=xlNo 'tri pour regrouper et accélérer
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.EntireColumn.Delete
End With
End With
End With
End Sub
Bonjour basnasone, bienvenue sur XLD,
Cette solution VBA suppose qu'il y a une (et une seule) ligne d'en-têtes :
A+VB:Sub SupprimerLignes() Dim tablo, i&, j& Application.ScreenUpdating = False With ActiveSheet.UsedRange.Offset(1) 'saute la ligne des en-têtes With .Resize(12 * Int(.Rows.Count / 12) + 12) 'multiple de 4 + 8 = 12 .Columns(1).EntireColumn.Insert 'colonne auxiliaire tablo = .Columns(0) 'matrice, plus rapide For i = 1 To UBound(tablo) Step 12 For j = i To i + 3 tablo(j, 1) = 1 'repère Next j, i With .Columns(0) .Value = tablo .EntireRow.Sort .Cells, Header:=xlNo 'tri pour regrouper et accélérer .SpecialCells(xlCellTypeBlanks).EntireRow.Delete .EntireColumn.Delete End With End With End With End Sub