Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long, t As Long
Dim dico As Object, r As Range, Couleurs
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
Couleurs = VBA.Array(40, 36, 43, 22)
With Sheets("Feuil1").Range("a1").CurrentRegion
a = .Value
ReDim b(1 To UBound(a, 1), 1 To Application.CountA(.Columns(1).Cells) * UBound(a, 2))
End With
n = 2: t = 3
b(2, 1) = "N°": b(2, 2) = "Nom": b(2, 3) = "Prénom"
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
If Not dico.exists(a(i, 2)) Then
n = n + 1: dico(a(i, 2)) = n
b(n, 1) = a(i, 2): b(n, 2) = a(i, 3): b(n, 3) = a(i, 4)
End If
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
b(1, t + 1) = a(i, 1)
End If
For j = 5 To UBound(a, 2)
If a(i, j) <> "" Then
If Not .Item(a(i, 1)).exists(a(i, j)) Then
Set .Item(a(i, 1))(a(i, j)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1))(a(i, j)).CompareMode = 1
t = t + 1
.Item(a(i, 1))(a(i, j)) = t
b(2, t) = a(i, j)
End If
b(dico(a(i, 2)), .Item(a(i, 1))(a(i, j))) = "x"
End If
Next
Next
End With
Application.ScreenUpdating = False
'restitution et mise en forme
With Sheets("Feuil2")
.Cells.Clear
With .Cells(1).Resize(n, t)
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Columns.ColumnWidth = 11
With .Rows(1)
.BorderAround Weight:=xlThin
With .Offset(, 3).Resize(, .Columns.Count - 3)
n = 0
For Each r In .SpecialCells(4).Areas
r(0).Resize(, r.Cells.Count + 1).Interior.ColorIndex = Couleurs(n)
r(0).Resize(, r.Cells.Count + 1).MergeCells = True
n = n + 1
If n > UBound(Couleurs) Then n = 0
r.EntireColumn.Hidden = True
Next
End With
End With
With .Rows(2)
.BorderAround Weight:=xlThin
.Resize(, 3).Interior.ColorIndex = 15
.Offset(, 3).Resize(, .Columns.Count - 3).Interior.ColorIndex = 44
End With
End With
.Activate
End With
Application.ScreenUpdating = True
End Sub