Sub мяу()
    Dim sh As Worksheet, sh1 As Worksheet, lr&, i&, ii&, spl, spl1
    Set sh = ActiveSheet
    Set sh1 = Worksheets.Add
    lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    sh.Range("A1").Resize(, 4).Copy sh1.Range("A1")
    ii = 2
    For i = 2 To lr
        spl = Split(sh.Cells(i, 2), ",")
        spl1 = Split(sh.Cells(i, 3), ",")
        sh1.Cells(ii, 1).Resize(UBound(spl) + 1).Merge
        sh1.Cells(ii, 1) = sh.Cells(i, 1)
        sh1.Cells(ii, 2).Resize(UBound(spl) + 1) = Application.Transpose(spl)
        sh1.Cells(ii, 3).Resize(UBound(spl) + 1) = Application.Transpose(spl1)
        sh1.Cells(ii, 4).Resize(UBound(spl) + 1).Merge
        sh1.Cells(ii, 4) = sh.Cells(i, 4)
        ii = sh1.Cells(Rows.Count, 2).End(xlUp).Row + 1
    Next
End Sub

Sub TextToRows()
Dim arr(), arrNew(), u&, i&, n1&, n2&, n&, j&
Dim iStr1, iStr2
With Worksheets("Как есть")
    arr = .Range("A2:D" & .Cells(Rows.Count, "B").End(xlUp).Row).Value
End With
u = UBound(arr) * UBound(Split(arr(1, 2), ",")) * 2
ReDim arrNew(1 To u, 1 To 4): u = 1
For i = 1 To UBound(arr)
    iStr1 = Split(arr(1, 2), ","): n1 = UBound(iStr1)
    iStr2 = Split(arr(1, 3), ","): n2 = UBound(iStr2)
    n = IIf(n1 > n2, n1, n2)
    For j = 0 To n
        arrNew(u, 1) = arr(i, 1)
        If n1 < j Then arrNew(u, 2) = Empty Else arrNew(u, 2) = Trim(iStr1(j))
        If n2 < j Then arrNew(u, 3) = Empty Else arrNew(u, 3) = Trim(iStr2(j))
        arrNew(u, 4) = arr(i, 4)
        u = u + 1
    Next
Next
Worksheets("Как есть").Range("F2").Resize(u, 4) = arrNew
End Sub