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

**Rick Rothstein** · 05-22-2012, 10:42 PM

*** NOTE - Revised code posted August 12, 2013 in response ***
*** to a problem Marcelo Branco pointed out in Message #19 ***

The following scenario seems to come up somewhat often at the various forums I participate in... take a table of data where one column contains delimited data and split that delimited data so that each item is on a row of its own, copying the associated data into the blank cells created by the split. Visually, we want to go from this table...

	A	B	C	D
1	Name	Client Number	Parts Ordered
2	Rick	1111111	P1, P2, P3
3	Sam	2222222	P2, P5
4	Joe	3333333	P3
5	Bill	4444444	P4, P6, P7, P8
6

to this one

	A	B	C	D
1	Name	Client Number	Parts Ordered
2	Rick	1111111	P1
3	Rick	1111111	P2
4	Rick	1111111	P3
5	Sam	2222222	P2
6	Sam	2222222	P5
7	Joe	3333333	P3
8	Bill	4444444	P4
9	Bill	4444444	P6
10	Bill	4444444	P7
11	Bill	4444444	P8
12

Below is a macro that will accomplish this task. Note though that I have generalize it somewhat. Usually in the requests the delimited data is in the last column as shown above, however, there is no need for this to be the case... this macro will allow any column to be the delimited column.

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 = "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) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn)) Then
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub

There are four constants (the Const statements) that you need to match to your actual worksheet conditions in order to work. The first is named Delimiter and it can be one or more characters long. The second is named DelimitedColumn and specifies the column letter containing the delimited cells. The third is named TableColumns and it specifies the columns occupied by your data (which must always include the column with the delimited cells. The last one is named StartRow and it specifies the row containing the first piece of data (that is, it is the row number below the headers, if any).

**snb** · 02-22-2013, 04:44 PM

Hi Rick

I tried to develop an alternative that doesn't need any writing into any worksheet. It will be done in memory completely (except writing the results of course).
You can see that I make use of all the special facilities that arrays offer us.
The macro is built on the example in this thread.

Code:

Sub M_snb()
    sn = Sheets(1).Cells(1).CurrentRegion
    
    For j = 1 To UBound(sn)
        c00 = c00 & "|" & Replace(String(UBound(Split(sn(j, 3), ",")), "|"), "|", j & "|") & j
    Next
    sq = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), Evaluate("transpose(row(1:" & UBound(sn, 2) & "))"))
    
    sp = Split(Join(Application.Transpose(Application.Index(sn, 0, 3)), ","), ",")
    For j = 0 To UBound(sp)
        sq(j + 1, 3) = sp(j)
    Next
    
    Cells(10, 1).Resize(UBound(sq), UBound(sq, 2)) = sq
End Sub

or another method:

Code:

Sub M_snb0()
    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

**venkatgoutham** · 04-29-2013, 04:17 PM

Originally Posted by snb

Hi Rick

I tried to develop an alternative that doesn't need any writing into any worksheet. It will be done in memory completely (except writing the results of course).
You can see that I make use of all the special facilities that arrays offer us.
The macro is built on the example in this thread.

Code:

Sub M_snb()
    sn = Sheets(1).Cells(1).CurrentRegion
    
    For j = 1 To UBound(sn)
        c00 = c00 & "|" & Replace(String(UBound(Split(sn(j, 3), ",")), "|"), "|", j & "|") & j
    Next
    sq = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), Evaluate("transpose(row(1:" & UBound(sn, 2) & "))"))
    
    sp = Split(Join(Application.Transpose(Application.Index(sn, 0, 3)), ","), ",")
    For j = 0 To UBound(sp)
        sq(j + 1, 3) = sp(j)
    Next
    
    Cells(10, 1).Resize(UBound(sq), UBound(sq, 2)) = sq
End Sub

or another method:

Code:

Sub M_snb0()
    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

**Rick Rothstein** · 04-29-2013, 07:34 PM

Originally Posted by venkatgoutham

Hi my problem is same like DAT only. but this macro is not working for issue. when apply the macro it's showing error Run-time error '1004': Application-defined or object-defined error.

You quote the code that 'snb' posted in response to my article, so I'll let him deal with your question (whenever he next checks into this thread) as it relates to his code, but I was wondering if you tried the code I posted in main article and whether you had problems using it as well?

**venkatgoutham** · 04-30-2013, 03:46 PM

Originally Posted by Rick Rothstein

You quote the code that 'snb' posted in response to my article, so I'll let him deal with your question (whenever he next checks into this thread) as it relates to his code, but I was wondering if you tried the code I posted in main article and whether you had problems using it as well?

**Rick Rothstein** · 04-30-2013, 07:43 PM

Originally Posted by venkatgoutham

yep i tried. it's working fine which u posted in main article .yesterday it's working fine for me. but today i am getting error (which i told in previous quote). so i have to know one thing. which times that error come. what i need check whether it's error came.

Can you attach a copy of the workbook that is giving you the error so that I can test the code out on your exact data to see where the problem is located at?

**snb** · 05-01-2013, 02:29 AM

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

Code:

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** · 05-31-2013, 12:47 AM

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** · 05-31-2013, 12:48 AM

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** · 05-31-2013, 01:33 AM

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.