VBA Return Carriage and Fill Code

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