Option Explicit
Sub test()
Dim a, b(), i As Long, maxcol As Long, n As Long, w(), x, pos
Const ub As Byte = 2
With Sheets("Etat").Cells(1).CurrentRegion
a = .Value
x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(4).Address & _
",,,row(1:" & .Rows.Count & "))," & .Columns(4).Address & ")=1, " & _
.Columns(4).Address & ",char(2)))"), Chr(2), 0)
ReDim b(1 To UBound(a, 1), 1 To 3)
n = 1: b(n, 1) = a(1, 1): b(n, 2) = a(1, 3)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1: ReDim w(1 To 2)
w(1) = n
Set w(2) = CreateObject("Scripting.Dictionary")
w(2).CompareMode = 1
w(2)(a(i, 2)) = Empty
b(n, 1) = a(i, 1): b(n, 2) = a(i, 3): b(n, 3) = a(i, 2)
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
If Not w(2).exists(a(i, 2)) Then
w(2)(a(i, 2)) = Empty
If UBound(b, 2) < ub + w(2).Count Then
ReDim Preserve b(1 To UBound(b, 1), 1 To ub + w(2).Count)
End If
b(w(1), ub + w(2).Count) = a(i, 2)
End If
.Item(a(i, 1)) = w
End If
Next
maxcol = UBound(b, 2)
ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + UBound(x))
For i = 3 To maxcol: b(1, i) = "Code format": Next
For i = 1 To UBound(x): b(1, maxcol + i) = "Nombre " & x(i): Next
For i = 2 To UBound(a, 1)
w = .Item(a(i, 1))
pos = Application.Match(a(i, 4), x, 0)
b(w(1), maxcol + pos - 1) = b(w(1), maxcol + pos - 1) + 1
Next
End With
End With
'Restitution et mise en forme
With Sheets("Feuil1").Cells(1)
.CurrentRegion.Clear
.Parent.Columns(1).Resize(, maxcol).NumberFormat = "@"
.Resize(n, UBound(b, 2)).Value = b
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 22
With .Offset(, 2).Resize(, .Columns.Count - 2 - UBound(x))
.Interior.ColorIndex = 38
End With
With .Offset(, maxcol).Resize(, .Columns.Count - maxcol)
.Interior.ColorIndex = 36
End With
End With
.Columns.ColumnWidth = 13
End With
.Parent.Activate
End With
End Sub