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

[snb]

I hope it's obvious that:
- this macro resides in the macromodule it refers to
- the ranges (A1:A6, B1:B6, etc.) have to be adapted to your specific situation
- the delimiter in column C is ", " and may have to be adapted to your specific situation

Sub M_snb()
    sn = Split(Join([transpose(A2:A6 & "_" & B2:B6 & "_" & substitute(C2:C6,", ","," & A2:A6 & "_" & B2:B6 & "_"))], ","), ",")
    Cells(20, 1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
    Cells(20, 1).CurrentRegion.TextToColumns , , , , False, False, False, False, True, "_"
End Sub

Your feedback is too limited to analyse what could have caused the error.
Posting a sample workbook could shed some more light.

[msrebraca]

Hi Rick,

I tried to use your macro and after updating the 4 constants I get a runtime error 1004 on the following line.

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

[msrebraca]

I only changed the constants to:

Const Delimiter As String = ";#"
Const DelimitedColumn As String = "D"
Const TableColumns As String = "A:D"
Const StartRow As Long = 2

Any ideas what could trigger the error on that line?

[Rick Rothstein]

Can you attach a sample file (that fails to work) to a response so that I can see what is happening directly? To attach a file, I think you would click the Reply link in the bottom border of this message and then click the "Go Advanced" button under the new reply box that appears... somewhere below that new reply box should be a button that will allow you to upload a file as an attachment.

[Trosko]

I'm trying to apply this macro to a spreadsheet that I have, but I'm having some issues. I keep getting a run time error. I've attached the file so that you can see what I'm working on.

Thanks for any help that you can lend!

[msrebraca]

Trosko, you are having the same issue that I faced, your deliminated column "L" has some blanks so the code errors out. I removed the rows with blanks in column L and the macro ran just fine.

So you'll need to update the macro to account for this. I wasn't able to figure that part out and in my case it didn't matter, rows with blanks in the deliminated column were not needed for my project so I was able to just delete those rows by inserting the following code in the macro. You'll notice I put the new code right after the delclarations and before the existing code.

Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = ", "
  Const DelimitedColumn As String = "D"
  Const TableColumns As String = "A:D"
  Const StartRow As Long = 2
  
Columns(4).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

[Trosko]

Trosko, you are having the same issue that I faced, your deliminated column "L" has some blanks so the code errors out. I removed the rows with blanks in column L and the macro ran just fine.

So you'll need to update the macro to account for this. I wasn't able to figure that part out and in my case it didn't matter, rows with blanks in the deliminated column were not needed for my project so I was able to just delete those rows by inserting the following code in the macro. You'll notice I put the new code right after the delclarations and before the existing code.

The modification worked great, but is there an easy to autofill the blanks with a value like "Null" rather than delete them?

[Trosko]

Things seem to go a little "wonky" when I hit 1179 rows - the macro still separates the rows, but it stops copying the information. Anyone have any idea why that might happen? Thanks!

[msrebraca]

You can select the range of cells in question and then use ctrl+F and the Replace All function to look for blanks and replace with NULL. Then run the original macro without the code that deletes the blanks.

[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