Bonsoir Lunatic, Force rouge, Amadéus, le forum
Une solution VBA, pas eu le temps de vraiment tester :
Option Explicit
Sub test()
Dim a, b(), i As Long, maxRow As Long, j As Long, w()
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1), 1 To 1)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 3)) Then
j = j + 1
If j > UBound(b, 2) Then
ReDim Preserve b(1 To UBound(b, 1), 1 To j)
End If
b(1, j) = "Couleur des cheveux " & a(i, 3)
.Item(a(i, 3)) = VBA.Array(1, j)
End If
w = .Item(a(i, 3))
w(0) = w(0) + 1
b(w(0), w(1)) = a(i, 2)
maxRow = Application.Max(maxRow, w(0))
.Item(a(i, 3)) = w
Next
End With
Application.ScreenUpdating = False
'Restitution en feuil3
With Sheets("Feuil3")
.Cells.Clear
With .Range("a1").Resize(maxRow, UBound(b, 2))
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.Interior.ColorIndex = 42
.BorderAround Weight:=xlThin
End With
.Columns.AutoFit
End With
.Activate
End With
Application.ScreenUpdating = True
End Sub
klin89