Option Explicit
Sub test()
Dim a, i As Long, w(), x, y, e
a = Sheets("Feuil1").Range("a4").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.comparemode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
.Item(a(i, 2)) = VBA.Array(a(i, 2), 1, a(i, 4), Empty, a(i, 1))
Else
w = .Item(a(i, 2))
w(1) = w(1) + 1
w(4) = w(4) & "," & a(i, 1)
.Item(a(i, 2)) = w
End If
Next
For Each e In .keys
w = .Item(e)
w(3) = w(1) / w(2)
.Item(e) = w
Next
x = .Count: y = .items
End With
'Restitution et mise en forme
Application.ScreenUpdating = False
With Sheets("Feuil2").Cells(1)
.Parent.Cells.Clear
.Resize(1, 5).Value = Array("Adhérents", "Nbre de prix", "Engagé", "% engagé", "Classement des prix")
.Offset(1).Resize(x, 5).Value = Application.Index(y, 0, 0)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.Font.Size = 11
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 38
.HorizontalAlignment = xlCenter
End With
With .Offset(1).Resize(.Rows.Count - 1)
With .Resize(, .Columns.Count - 1)
.HorizontalAlignment = xlCenter
End With
.Columns(4).NumberFormat = "0%"
.Columns(5).NumberFormat = "@"
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub