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

**Trosko** · 07-19-2013, 11:47 PM

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** · 07-20-2013, 12:19 AM

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.

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

**Marcelo Branco** · 08-10-2013, 11:29 PM

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

**Rick Rothstein** · 08-12-2013, 09:40 PM

Originally Posted by 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

Code:

  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.

**jamilm** · 08-18-2013, 07:27 PM

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.

**Jalyra** · 11-06-2013, 01:13 AM

Hello. This macro works beautifully, however is there a way to do this same function to multiple columns with multi-values?

My data looks like this:

Column 1 Column 2 Multi-value Column Multi-value column
Data Data RMA;-;RMA 65044;99944;65033

The multi-values all correspond with each other.

This is a break down of service work orders, line items such as labor, travel, parts and if it is returnable.

Your help is greatly appreciated.

**Wajiha** · 11-25-2014, 10:20 AM

Hi Rick,

Great piece of code

i have a macro data file that contains empty cells too. when i run this code it fills all the empty cells to the values to the upper cell whether needed or not.i want to copy only those rows which have delimited values in the (delimited) column.
Can you help me fix the code so that i only creates new rows for the splited column.

A B C
a b,c,d l
k u
v,k i

The results should be:
A B C
a b l
a c l
a d l
k u
v i
k k
Thanks
Wajiha

**rpg1966** · 03-13-2015, 02:26 PM

I felt that I had to tell you that this is incredibly useful, and I thank you very much.

But to avoid falling foul of the rule "4. DO NOT post one liners thanking members or post remarks like "Wow, this is helpful", or "This is great" etc.", my situation has one additional requirement that you might be willing to look at.

In the table in post #1, the delimited "Parts Ordered" column has different data in each cell. Would it be possible to get the macro to skip a row entirely, if the "Parts Ordered" delimited data in row x is the same as in row (x-1)?

**msrebraca** · 05-31-2013, 05:38 PM

Hi Rick,

I have attached the file for your review. The file was too large to attach so I stripped most of the data leaving enough for you to work with. Also I changed the delimiter to ", " using the replace all function, was hoping that would help but it did not.

The other part that I was not sure of was where to place the macro, in the worksheet or module either way I get an error. The attachment currently has it in the module.

Thanks for taking a look:-)