Option Base 1
Sub schtroumph()
Dim tabRes() As Variant
tabRes = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 2))
Dim max As Double
max = 0
For i = LBound(tabRes, 1) To UBound(tabRes, 1)
If max < UBound(Split(tabRes(i, 1), ",")) + 1 Then
max = UBound(Split(tabRes(i, 1), ",")) + 1
End If
Next i
ReDim Preserve tabRes(LBound(tabRes, 1) To UBound(tabRes, 1), LBound(tabRes, 2) To 2 + max)
' Nettoyage zone
Range(Cells(2, 3), Cells(Cells(65536, 1).End(xlUp).Row, 2 + max)).ClearContents
For i = LBound(tabRes, 1) To UBound(tabRes, 1)
temp1 = Split(tabRes(i, 1), ",")
temp2 = Split(tabRes(i, 2), ",")
For j = LBound(temp1) To UBound(temp1)
If tabRes(i, temp1(j) + 2) = Empty Then
tabRes(i, temp1(j) + 2) = Split(tabRes(i, 2), ",")(j)
Else
tabRes(i, temp1(j) + 2) = tabRes(i, temp1(j) + 2) & "," & Split(tabRes(i, 2), ",")(j)
End If
Next j
Erase temp1, temp2
Next i
Cells(2, 1).Resize(UBound(tabRes, 1), UBound(tabRes, 2)) = tabRes
End Sub