Private Sub Worksheet_Activate()
Dim ncol%, dercol%, t(), u&, d As Object, i&, s, lig&, col%, v%, j%, L&
ncol = 4 'nombre de colonnes du tableau, à adapter
dercol = ncol
With Feuil1 'CodeName de la feuille source, à adapter
t = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, ncol)
u = UBound(t)
Set d = CreateObject("Scripting.Dictionary")
'---transfert des valeurs---
For i = 1 To u
If d.exists(t(i, 1)) Then
s = Split(d(t(i, 1)))
lig = s(0): col = s(1)
v = col + ncol - 1
If v > dercol Then dercol = v: ReDim Preserve t(1 To u, 1 To v)
For j = 1 To ncol - 1
t(lig, col + j) = t(i, j + 1)
Next
d(t(i, 1)) = lig & " " & v 'mise à jour mémorisation
Else
L = L + 1
d(t(i, 1)) = L & " " & ncol 'ligne et colonne mémorisées
For j = 1 To ncol
t(L, j) = t(i, j)
Next
End If
Next
'---restitution et titres---
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
[A2].Resize(L, dercol) = t
.[A1].Copy [A1]
.[B1].Resize(, ncol - 1).Copy [B1].Resize(, dercol - 1)
End With
End Sub