Split cell values into multiple rows and keep other data

Try this, you can easily adjust it to your actual sheet name and column to split.

Sub splitByColB()
    Dim r As Range, i As Long, ar
    Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
    Do While r.row > 1
        ar = Split(r.value, ",")
        If UBound(ar) >= 0 Then r.value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.EntireRow.Copy
            r.Offset(1).EntireRow.Insert
            r.Offset(1).value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop
End Sub

You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:

Dim workingRow As Long
workingRow = 2
With ActiveSheet
    Do While Not IsEmpty(.Cells(workingRow, 2).Value)
        Dim values() As String
        values = Split(.Cells(workingRow, 2).Value, ",")
        If UBound(values) > 0 Then
            Dim colA As Variant, colC As Variant, colD As Variant
            colA = .Cells(workingRow, 1).Value
            colC = .Cells(workingRow, 3).Value
            colD = .Cells(workingRow, 4).Value
            For i = LBound(values) To UBound(values)
                If i > 0 Then
                    .Rows(workingRow).Insert xlDown
                End If
                .Cells(workingRow, 1).Value = colA
                .Cells(workingRow, 2).Value = values(i)
                .Cells(workingRow, 3).Value = colC
                .Cells(workingRow, 4).Value = colD
                workingRow = workingRow + 1
            Next
        Else
            workingRow = workingRow + 1
        End If
    Loop
End With