Bonjour _avenueB, Jean-Eric
Essaie ceci :
Option Explicit
Sub test()
Dim a, b(), i As Long, dico1 As Object, dico2 As Object, txt As String
Set dico1 = CreateObject("Scripting.Dictionary")
dico1.comparemode = 1
Set dico2 = CreateObject("Scripting.Dictionary")
dico2.comparemode = 1
a = Sheets("Initial").Cells(1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not dico1.exists(a(i, 4)) Then
dico1(a(i, 4)) = dico1.Count + 4
End If
Next
ReDim b(1 To UBound(a, 1), 1 To dico1.Count + 3)
b(1, 1) = a(1, 1): b(1, 2) = a(1, 2): b(1, 3) = a(1, 3)
For i = 0 To dico1.Count - 1
b(1, i + 4) = dico1.keys()(i)
Next
For i = 2 To UBound(a, 1)
txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
If Not dico2.exists(txt) Then
dico2(txt) = dico2.Count + 2
b(dico2(txt), 1) = a(i, 1)
b(dico2(txt), 2) = a(i, 2)
b(dico2(txt), 3) = a(i, 3)
End If
b(dico2(txt), dico1(a(i, 4))) = a(i, 5)
Next
Application.ScreenUpdating = False
With Sheets.Add().[a1].Resize(dico2.Count + 1, dico1.Count + 3)
With .Rows(1)
.Borders.Weight = 2
.Interior.ColorIndex = 15
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.Value = b
.Borders.Weight = 2: .Columns.AutoFit
End With
Application.ScreenUpdating = True
Set dico1 = Nothing: Set dico2 = Nothing
End Sub
Attention aux espaces parasites en fin de chaîne dans la colonne couleur.
klin89