Create Duplicate Rows for multiple values in a Column.

Try this:

Sub foo()
    Dim lRow As Long, lItems As Long, i As Integer, s() As String
    With ActiveSheet
        For lRow = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
            s = Split(.Cells(lRow, 2).Value, ",")
            lItems = UBound(s)
            If lItems > 0 Then
                With .Cells(lRow, 1)
                    .Offset(1, 0).Resize(lItems, 1).EntireRow.Insert
                    For i = 0 To lItems
                        .Offset(i, 0).Value = .Value
                        .Offset(i, 1).Value = Trim(s(i))
                        .Offset(i, 2).Value = .Offset(0, 2).Value
                    Next i
                End With
            End If
        Next lRow
    End With
End Sub

Hi Mac,

Welcome to the Forum

Just add one line to ollies code as the red code below:

Sub foo() 'olly
    Dim lRow As Long, lItems As Long, i As Integer, s() As String
    With ActiveSheet
        For lRow = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
            s = Split(.Cells(lRow, 2).Value, ",")
            lItems = UBound(s)
            If lItems > 0 Then
                With .Cells(lRow, 1)
                .EntireRow.Copy
                    .Offset(1, 0).Resize(lItems, 1).EntireRow.Insert
                    For i = 0 To lItems
                        .Offset(i, 0).Value = .Value
                        .Offset(i, 1).Value = Trim(s(i))
                        .Offset(i, 2).Value = .Offset(0, 2).Value
                    Next i
                End With
            End If
        Next lRow
    End With
End Sub

Thanks for the rep!