Option Explicit
Sub test()
Dim a, w(), x(), i As Long, n As Long, t As Long, txt As String, e
Dim dico As Object, pos As Byte, couleurs()
couleurs = VBA.Array(36, 40, 22)
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
If Not .exists(txt) Then
n = n + 1
.Item(txt) = n
End If
If Not dico.exists(a(i, 3)) Then
ReDim w(1 To 3)
'attention à la 2ème dimension
ReDim x(1 To UBound(a, 1), 1 To 10)
Set w(1) = CreateObject("Scripting.Dictionary")
w(1).CompareMode = 1
w(3) = 0
Else
w = dico(a(i, 3))
x = w(2)
End If
w(1)(txt) = w(1)(txt) + 1
x(.Item(txt), w(1)(txt)) = a(i, 4)
pos = w(1)(txt)
If pos > w(3) Then
x(1, w(1)(txt)) = "GEN_PNEU " & pos
End If
w(2) = x
w(3) = Application.Max(w(3), pos)
dico(a(i, 3)) = w
Next
ReDim b(1 To .Count, 1 To 2)
n = 0
For Each e In .keys
n = n + 1
b(n, 1) = Split(e, Chr(2))(0)
b(n, 2) = Split(e, Chr(2))(1)
Next
End With
'restitution
Application.ScreenUpdating = False
With Sheets("Feuil2").Cells(1)
.CurrentRegion.Clear
With .Offset(1)
.Value = "COD_FPNEU"
.Interior.ColorIndex = 43
End With
With .Offset(1, 1)
.Value = "COM_DIM"
.Interior.ColorIndex = 44
End With
With .Offset(2).Resize(UBound(b, 1), UBound(b, 2))
.Value = b
End With
t = 2: n = 0
For i = 0 To dico.Count - 1
With .Offset(, t)
.Value = dico.keys()(i)
With .Resize(, dico.items()(i)(3))
.HorizontalAlignment = xlCenterAcrossSelection
.BorderAround Weight:=xlThin
.Interior.ColorIndex = couleurs(n)
n = n + 1
If n > UBound(couleurs) Then n = 0
End With
End With
With .Offset(1, t)
With .Resize(UBound(b, 1) + 1, dico.items()(i)(3))
.NumberFormat = "@"
.Value = dico.items()(i)(2)
End With
End With
t = t + dico.items()(i)(3)
Next
With .CurrentRegion
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Font.Name = "calibri"
.Rows(1).Font.Size = 11
.Rows(2).BorderAround Weight:=xlThin
With .Offset(1).Resize(.Rows.Count - 1)
.HorizontalAlignment = xlCenter
.Font.Size = 9
End With
.Columns(1).ColumnWidth = 12
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Columns.ColumnWidth = 16
End With
End With
.Parent.Activate
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub