Option Explicit
Sub Regroupement()
Dim a, i As Long, j As Long, n As Long, col As Byte, w
a = Sheets("Feuil1").Range("A2").CurrentRegion.Value
col = UBound(a, 2): n = 1: a(1, 20) = "Fonction n° 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
n = n + 1: .Item(a(i, 2)) = VBA.Array(n, col)
For j = 1 To col
a(n, j) = a(i, j)
Next
Else
w = .Item(a(i, 2)): w(1) = w(1) + 5
If UBound(a, 2) < w(1) Then
ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
a(1, w(1) - 4) = a(1, 20)
a(1, w(1) - 3) = a(1, 21)
a(1, w(1) - 2) = a(1, 22)
a(1, w(1) - 1) = a(1, 23)
a(1, w(1)) = a(1, 24)
End If
For j = 1 To 5
a(w(0), w(1) - 5 + j) = a(i, j + 19)
Next
.Item(a(i, 2)) = w
End If
Next
End With
'Restitution et mise en forme en Feuil2
Application.ScreenUpdating = False
With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
.CurrentRegion.Clear
.Value = a
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.Font.Size = 11
.Interior.ColorIndex = 38
.BorderAround Weight:=xlThin
End With
.Columns.AutoFit
.Rows.RowHeight = 19
End With
If UBound(a, 2) > 24 Then
With .Offset(, 19).Resize(1, 5)
.AutoFill .Resize(, UBound(a, 2) - 19)
End With
End If
.Parent.Select
End With
Application.ScreenUpdating = True
End Sub