Split cell values into multiple rows and keep other data

Question

I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.

I have a variable number of rows.

I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.

Example:

ColA       ColB       ColC      ColD
Monday     A,B,C      Red       Email

Output:

ColA       ColB       ColC      ColD
Monday       A         Red       Email
Monday       B         Red       Email
Monday       C         Red       Email

Have tried something like:

colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
    Rows.Insert(i)
Next i

Answer 1

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

Answer 2

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