Redistribute a Delimited Column Of Data into Separate Rows (Keeping Other Data As Is)

[Marcelo Branco]

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

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

The solution I found is (modifications in blue)

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

[Rick Rothstein]

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

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

Thank you so much for pointing out this problem to me... I cannot believe it did not occur to me to test data where one or more of the cells are emptly. And thank you for your code suggestion as well; however, I decided to take a different route in fixing the problem. Your alert to me allowed me to review my code with "fresh eyes" and I saw a way to correct the problem while at the same time tighten up the code somewhat (I managed to eliminate the last For..Next loop entirely). I replaced the original code in Message #1 with my new code and put a note at the top indicating that message contains revised code (for those who previously visited this thread and then re-visit it in the future). Thank you again for pointing out the problem to me... I really appreciated it.

[Marcelo Branco]

Rick,

I'm glad for, somehow, have contributed to a better solution.

New code copied for future use.

Regards,

M.

[jamilm]

very nice. i was looking for this code. coincidentally, i searched before posting the question in Mrexcel forum and here i got exactly what i needed.

thank you Rick and Marcelo.

[kristofpoppe]

Nice piece of code, although I see a problem, when a value is blank in another collumn, it is copied from the cell that contains a value, so it filles other empty cells with bogus data

Eg.

AA BBB 1:2
CC 2:3

Will become:

AA BBB 1
AA BBB 2
CC BBB 2
CC BBB 3

Any solution for this ?