Sub gratagui()
Dim Ws1 As Worksheet, Ws2 As Worksheet, DerLig As Long, TabloA, i As Long
Set Ws1 = Worksheets("Liste") ' Nom de la feuille ou se trouvent les données
Set Ws2 = Worksheets("Feuil2") ' Nom de la feuille ou les données seront copiées et traitées
'suppression des lignes feuil2
Ws2.Cells.Delete
DerLig = Ws1.Range("A" & Rows.Count).End(xlUp).Row ' recherche du N° de la dernière ligne
TabloA = Ws1.Range("A4:D" & DerLig) 'copie des données dans un tableau
Application.ScreenUpdating = False
With Ws2
.Range("A4").Resize(UBound(TabloA, 1), 4) = TabloA 'copie du tableau dans la feuille de travail
'copie des entêtes
Ws1.Range("A1:D3").Copy
With .Range("A1:D3")
.PasteSpecial 'Paste:=xlPasteAll
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
End With
.Range("A1:D" & DerLig).HorizontalAlignment = xlCenter
.Range("B4:B" & DerLig).HorizontalAlignment = xlLeft
.Range("C2:D" & DerLig).Interior.ColorIndex = 16
'suppression et regroupement des lignes
For i = DerLig To 4 Step -1 ' de la dernière à la 4ème ligne
If .Cells(i, 1) = .Cells(i - 1, 1) Then 'si N° de boite est ègal celui de la ligne précédente
.Cells(i - 1, 2) = .Cells(i - 1, 2) & " ; " & .Cells(i, 2) 'copie la description dans la ligne du dessus
.Rows(i).Delete Shift:=xlUp 'suppression de la ligne courante
End If
Next
End With
Application.ScreenUpdating = True
End Sub