Hi Rick,

Excellent code, I must say, but I found a problem if, for any reason, a customer has the column C blank.

Something like (Joe has no Parts)

Name Client Parts
Rick 1111111 P1, P2, P3
Sam 2222222 P2, P5
Joe 3333333
Bill 4444444 P4, P6, P7, P8


This line of code throws an error

Code:
  Intersect (Rows (X + 1), Columns (TableColumns)). Resize (UBound (Data)). XlShiftDown Insert

The solution I found is (modifications in blue)

Code:
Sub RedistributeDataV2()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = ", "
  Const DelimitedColumn As String = "C"
  Const TableColumns As String = "A:C"
  Const StartRow As Long = 2
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data = Split(Cells(X, DelimitedColumn), Delimiter)
        
   If UBound(Data) And UBound(Data) <> -1 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  
  On Error GoTo NoBlanks
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow) _
    .Resize(LastRow - StartRow + 1, Columns(TableColumns).Columns.Count - 1))  
 On Error GoTo 0

  For Each A In Table.SpecialCells(xlBlanks).Areas
        A.FormulaR1C1 = "=R[-1]C"
        A.Value = A.Value
  Next
NoBlanks:
  Application.ScreenUpdating = True
End Sub

This is reasonable or is there another more efficient solution?

Best Regards,

Marcelo