VBA Return Carriage and Fill Code - vba

Question

I'm really new to vba and would appreciate any assistance in the following problem I'm having.
Problem description (in relation to diagram below):
1*) In c, I have managed to separate the return carriages, which leads to 2*) now that each return carriage has it's own row, I need column b and c on either side to be filled down as shown in result 3*)
1*) b c e
y 1,2,3,4 y
z 5,6,7,8 z
2*) b c e
y 1 y
2
3
4
z 5 z
6
7
8
3*) b c e
y 1 y
y 2 y
y 3 y
y 4 y
z 5 z
z 6 z
z 7 z
z 8 z
I have included my original code for everyone to inspect, I am currently stuck as to how I would get to step 3.
Sub InString()
Dim rColumn As Range 'Set this to the column which needs to be worked through
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long 'Difference between first and last row
Dim lLFs As Long
Dim rRow As Range 'This will be used to drag the fill down between rows
Set rColumn = Columns("N")
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row
For lRow = lLastRow To lFirstRow Step -1
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
If lLFs > 0 Then
rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down.
rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
End If
Next lRow
End Sub
Thanks,

Answer 1

I just added a loop at the end looking for blanks -
Sub InString()
Dim rColumn As Range 'Set this to the column which needs to be worked through
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long 'Difference between first and last row
Dim lLFs As Long
Dim rRow As Range 'This will be used to drag the fill down between rows
Dim strVal As String
Set rColumn = Columns("N")
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row
For lRow = lLastRow To lFirstRow Step -1
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
If lLFs > 0 Then
rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down.
rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
End If
Next lRow
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row
Dim rColNum As Integer
rColNum = rColumn.Column
For i = 2 To lLastRow
If Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
End If
Next
End Sub
Basically this part -
For i = 2 To lLastRow
If Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
End If
Next
Says, look at each row in the column we just split and see if the cell to the left is blank. If it is, make it the same as the one above it AND make the cell to the right the same as the one above it.
To expand, you might then say
if Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
Cells(i, rColNum - 2) = Cells(i - 1, rColNum - 2)
Cells(i, rColNum + 2) = Cells(i - 1, rColNum + 2)
End If
If you wanted to cover the adjacent two columns on either side of rcolumn.

Answer 2

Assuming your input data is in columns B, D and E (as your diagram suggests) then this does the job I think:
Sub OrderData()
Dim inputData As Range, temp() As Variant, splitData As Variant, i As Integer, j As Integer, rw As Long
Set inputData = Range("B1:E2") //Update to reflect your data
temp = inputData.Value
inputData.ClearContents
rw = 1
For i = 1 To UBound(temp)
splitData = Split(temp(i, 2), ",")
For j = 0 To UBound(splitData)
Cells(rw, 2) = temp(i, 1)
Cells(rw, 3) = splitData(j)
Cells(rw, 5) = temp(i, 4)
rw = rw + 1
Next j
Next i
End Sub