Private Sub Worksheet_Activate()
Dim P As Range, i&, a As Range, tablo
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
Set P = Feuil1.[A:A].SpecialCells(xlCellTypeConstants, 1) 'nombres
Cells.Delete 'RAZ
For i = 1 To P.Areas.Count
Set a = P.Areas(i)
tablo = a.Offset(-3).Resize(a.Count + 3)
If InStr(a(1).Offset(-4), ":") Then tablo(1, 1) = a(1).Offset(-4) & " " & tablo(1, 1) 'concaténation si prolongation
Cells(i, 1).Resize(, UBound(tablo)) = Application.Transpose(tablo)
Next
Columns.AutoFit 'ajustement largeurs
End Sub