Sub d()
Dim i&, x&, y&, t
[Tbo].Copy
On Error Resume Next
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = "$$$"
For i = Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
If InStr(Cells(i, "B"), ";") > 0 Then
t = Split(Cells(i, "B"), ";")
x = Cells(i, "B").Offset(1).Row
y = UBound(t)
Rows(x).Resize(y).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(i, "B").Resize(y + 1) = Application.Transpose(t)
Cells(i, "A").Resize(y + 1).FillDown
Cells(i, "C").Resize(y + 1).FillDown
End If
Next
[A1].CurrentRegion.Copy Feuil1.[F2]
Application.DisplayAlerts = False
Sheets("$$$").Delete
End Sub