Splitting multiple cells with comma separated values into rows

[amritb]

Hi All I'm trying to do the following with no luck

Current:
Headers: Name | Programs Enrolled In | Date Enrolled in Program
Row 1: Name A | Program A, Program B, Program C | 1/25/2021, 5/25/2020, 6/14/2019
Row 2: Name B | Program A, Program E | 1/18/2018, 5/12/2018

What I Want:
Headers: Name | Programs Enrolled In | Date Enrolled in Program
Row 1: Name A | Program A | 1/25/2021
Row 2: Name A | Program B | 5/25/2020
Row 3: Name A | Program C | 6/14/2019
Row 4: Name B | Program A | 1/18/2018
Row 5: Name B | Program E | 5/18/2018

Thanks for any help

 

[rollis13]

Have a try with what I came up with. Source will be Sheet1 and destination Sheet2. The macro can to be pasted in a standard module:

Option Explicit
Sub Split_Cells_Into_Rows()
    Dim srcRange As Range, destRange As Range
    Dim i      As Long, j As Long, k As Long
    Dim startRow As Long, endRow As Long
    Dim names, enrolProg, enrolDate
    Application.ScreenUpdating = False
    startRow = 1
    endRow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
    Set srcRange = Sheets(1).Range("A" & startRow & ":C" & endRow) 'source
    Set destRange = Sheets(2).Range("A1")         'destination
    With destRange.Worksheet
        Range(destRange, .Cells(.Rows.Count, destRange.Column).End(xlUp)(1, "C")).ClearContents
    End With
    k = 1
    For i = startRow To endRow
        enrolProg = Split(srcRange(i, "B"), ",")
        enrolDate = Split(srcRange(i, "C"), ",")
        For j = LBound(enrolProg) To UBound(enrolProg)
            destRange(k, "A") = Trim(srcRange(i, "A"))
            destRange(k, "B") = Trim(enrolProg(j))
            If j <= UBound(enrolDate) Then
                destRange(k, "C") = Trim(enrolDate(j))
            End If
            k = k + 1
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

 

[kweaver]

Welcome to Mr. Excel,

I took another approach and it seems to work as well.
Results went into the J column which could be changed in the macro.

Sub Regroup()
Dim lr As Long, i As Long, W As Long, j As Long, n As Long, c As Long, cc As Long
Dim st As String, ary1() As String, ary2() As String, ary3() As String

j = 1
lr = Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To lr
 n = 0.5 * (2 + UBound(Split(Range("A" & i), ","), 1))
 ' put solutions in J column (adjust accordingly)
 W = InStr(1, Cells(i, "A"), "|")
 st = Left(Cells(i, "A"), W) & " ,"
 st = Replace(String(n, "X"), "X", st)
 st = Left(st, Len(st) - 1)
 ary1 = Split(st, ",")
 
 st = Right(Cells(i, "A"), Len(Cells(i, "A")) - (W + 1))
 W = InStr(st, "|")
 st = Left(st, W - 2)
 ary2 = Split(st, ",")
 
 st = Right(Cells(i, "A"), W - 2)
 ary3 = Split(st, ",")
 
 cc = 0
 For c = j To j + n - 1
 Cells(c, 10) = ary1(cc) & Trim(ary2(cc)) & " | " & Trim(ary3(cc))
 cc = cc + 1
 Next c
 j = j + n
Next i
End Sub

 

[Marc L]

Hi, the easy fast Split way VBA demonstration for starters :​

Sub Demo1()
  Const D = ", "
    Dim V, W, L&, B, C, N&, R&
  ReDim V(1 To Rows.Count - 1, 1 To 3)
        W = [A1].CurrentRegion.Value2
    For L = 2 To UBound(W)
        B = Split(W(L, 2), D)
        C = Split(W(L, 3), D)
    For N = 0 To UBound(B)
        R = R + 1
        V(R, 1) = W(L, 1)
        V(R, 2) = B(N)
        V(R, 3) = C(N)
    Next N, L
        [A2:C2].Resize(R).Formula = V
End Sub