Option Explicit
Sub transpose()
Dim a, i As Long, j As Long, maxCol As Long, dico As Object, txt As String
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1").Range("a1").CurrentRegion
a = .Value
With dico
For i = 1 To UBound(a, 1)
txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
If Not .exists(txt) Then
Set .Item(txt) = CreateObject("Scripting.Dictionary")
End If
.Item(txt)(.Item(txt).Count) = VBA.Array(a(i, 3), a(i, 4))
maxCol = Application.Max(maxCol, .Item(txt).Count)
Next
ReDim a(1 To .Count, 1 To maxCol * 2 + 2)
For i = 0 To .Count - 1
a(i + 1, 1) = Split(.keys()(i), Chr(2))(0)
a(i + 1, 2) = Split(.keys()(i), Chr(2))(1)
For j = 0 To .items()(i).Count - 1
a(i + 1, j + 3) = .items()(i).items()(j)(0)
a(i + 1, j + 3 + maxCol) = .items()(i).items()(j)(1)
Next
Next
End With
Application.ScreenUpdating = False
With .Offset(, .Columns.Count + 2).Resize(dico.Count, maxCol * 2 + 2)
.CurrentRegion.Clear
.Value = a
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.Font.Size = 11
.Interior.ColorIndex = 43
.BorderAround Weight:=xlThin
End With
With .Cells(1, 3)
.Value = .Value & " 1"
If maxCol > 1 Then
.AutoFill .Resize(, maxCol)
End If
.Resize(, maxCol).Interior.ColorIndex = 6
End With
With .Cells(1, maxCol + 3)
.Value = .Value & " 1"
If maxCol > 1 Then
.AutoFill .Resize(, maxCol)
End If
.Resize(, maxCol).Interior.ColorIndex = 40
End With
.Columns.AutoFit
End With
End With
End With
Application.ScreenUpdating = True
End Sub