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

[Rick Rothstein]

*** 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.


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]

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.


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:


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



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://eileenslounge.com/viewtopic.php?p=317218#p317218 (https://eileenslounge.com/viewtopic.php?p=317218#p317218)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316940#p316940 (https://eileenslounge.com/viewtopic.php?p=316940#p316940)
https://eileenslounge.com/viewtopic.php?p=316927#p316927 (https://eileenslounge.com/viewtopic.php?p=316927#p316927)
https://eileenslounge.com/viewtopic.php?p=317014#p317014 (https://eileenslounge.com/viewtopic.php?p=317014#p317014)
https://eileenslounge.com/viewtopic.php?p=317006#p317006 (https://eileenslounge.com/viewtopic.php?p=317006#p317006)
https://eileenslounge.com/viewtopic.php?p=316935#p316935 (https://eileenslounge.com/viewtopic.php?p=316935#p316935)
https://eileenslounge.com/viewtopic.php?p=316875#p316875 (https://eileenslounge.com/viewtopic.php?p=316875#p316875)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (https://www.eileenslounge.com/viewtopic.php?p=314940#p314940)
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926 (https://www.eileenslounge.com/viewtopic.php?p=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[venkatgoutham]

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.


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:


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



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.

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://eileenslounge.com/viewtopic.php?p=317218#p317218 (https://eileenslounge.com/viewtopic.php?p=317218#p317218)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316940#p316940 (https://eileenslounge.com/viewtopic.php?p=316940#p316940)
https://eileenslounge.com/viewtopic.php?p=316927#p316927 (https://eileenslounge.com/viewtopic.php?p=316927#p316927)
https://eileenslounge.com/viewtopic.php?p=317014#p317014 (https://eileenslounge.com/viewtopic.php?p=317014#p317014)
https://eileenslounge.com/viewtopic.php?p=317006#p317006 (https://eileenslounge.com/viewtopic.php?p=317006#p317006)
https://eileenslounge.com/viewtopic.php?p=316935#p316935 (https://eileenslounge.com/viewtopic.php?p=316935#p316935)
https://eileenslounge.com/viewtopic.php?p=316875#p316875 (https://eileenslounge.com/viewtopic.php?p=316875#p316875)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (https://www.eileenslounge.com/viewtopic.php?p=314940#p314940)
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926 (https://www.eileenslounge.com/viewtopic.php?p=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[Rick Rothstein]

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]

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?

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.


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[Rick Rothstein]

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]

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.

[msrebraca]

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:-)

[msrebraca]

Hi Rick,

I just figured out the issue, some rows do not have data in the Delimited column which makes the code error. Anyway to tweek the code so it bypasses such rows?


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[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).EntireRo w.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.

[Trosko]

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.

Thanks! I knew there would be something really easy that I wasn't thinking of.

[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.:duh: 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 ?

[Jalyra]

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.

[madaboutmygirls]

Hi Rick,
This is great and is almost exactly what I am looking for. I have two (hopefully small) issues with the code though.

What I changed: I updated the range from A:C to be A:Z,and to start at Row 6 (headings in row 5) as per my data. Then have created the macro twice to once sperate column G and then next Column E. This works great (although I am sure you could do this in one - but it is beyond me to manipulate it that much).

Issue 1: comes when I look at the copied data results. Column U to Y have a heading in Row 5 but no data/are blank (they are for use later on). So no data should have been copied. But instead the code copies the headings from Row 5...?? ANy ideas on how to fix this?

Issue 2: comes when I have 2 columns column C+D that I need to split together - C is material number and D is material Name.
e.g
material number Material Name
100017, 100018 Mat A, Mat B

Should become
Mateiral Number Material Name
100017 Mat A
100018 Mat B

If I was to run the eixisting macro twice for Column C then D I would actually get after the first run
100017 Mat A, Mat B
100018 Mat A, Mat B
Then after the second run
100017 Mat A
100017 Mat B
100018 Mat A
100018 Mat B

Any ideas?

Many Thanks in advance!

[aselcuks]

*** 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.


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).




Hi, There occurs a problem with the other columns. Some of the columns are not fully completed, I mean half of the column has something in it and the other half is empty. When I run the code, it fullfills the other rest of the column with the value of last unempty cell. It stretches the last cell to the length of the longest column. Does any body have an idea with this code to fix it?

Thanks in advance,
Regards,

[Rick Rothstein]

When I run the code, it fullfills the other rest of the column with the value of last unempty cell. It stretches the last cell to the length of the longest column. Does any body have an idea with this code to fix it?

That is how the code was designed. When data is missing and the user wants to fill it in, normally they want to do that fill for the data item and, since there is no way to know how far that last item should be filled for, I chose to use the row with the last data item as the stopping point. Until your post, that is the functionality everyone has wanted. If you post a sample worksheet with existing data on Sheet1 and what you want that data to look like on Sheet2, I will try to modify the code for you to do what you show me you want.

[aselcuks]

That is how the code was designed. When data is missing and the user wants to fill it in, normally they want to do that fill for the data item and, since there is no way to know how far that last item should be filled for, I chose to use the row with the last data item as the stopping point. Until your post, that is the functionality everyone has wanted. If you post a sample worksheet with existing data on Sheet1 and what you want that data to look like on Sheet2, I will try to modify the code for you to do what you show me you want.


1679

That is the sheet I wanna modify and after the code executed I want it to be like;



1680


but It fullfills the rest of column K with the last statement "C15" and it goes down to length of longest column.


Thank you for your concern.

Regards

[aselcuks]

1679

That is the sheet I wanna modify and after the code executed I want it to be like;



1680


but It fullfills the rest of column K with the last statement "C15" and it goes down to length of longest column.


Thank you for your concern.

Regards




Also if there is any blank cell lets say G20, after execution it fulfills the shifted cell of G20 with the value of G19, it doesnt leave it blank as it was before.

[snb]

Sub M_snb()
sn = Sayfa1.Cells(1).CurrentRegion
sp = Split(Join(Application.Transpose(Application.Index (sn, 0, 4)), ","), ",")

c00 = "1_"
For j = 2 To UBound(sn)
c00 = c00 & Replace(Space(sn(j, 3)), " ", j & "_")
Next
st = Application.Index(sn, Application.Transpose(Split(c00, "_")), [transpose(row(1:12))])

For j = 2 To UBound(st) - 1
st(j, 4) = sp(j - 1)
Next

Sayfa1.Cells(40, 1).Resize(UBound(st) - 1, UBound(st, 2)) = st
End Sub

[Aisha13]

*** 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.


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).





Hi Rick,

I'm trying to do something similar. I have an excel with 45 columns. there are 5 or 6 columns with Commas that I want to split into a new row. Below you can find the code that I have so far:


Sub SplitData()
Dim arrColC As Variant
Dim arrColm As Variant
Dim arrColw As Variant
Dim arrColz As Variant
Dim arrCole As Variant
Dim arrColh As Variant
Dim shDATA As Worksheet
Dim r As Long, c As Long, i As Long, m As Long, x As Long, w As Long, j As Long, a As Long, z As Long, b As Long, e As Long, d As Long, n As Long, k As Long, y As Long, h As Long


Set shDATA = Sheets("owssvr")
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each MyRange In ActiveSheet.UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), ",")
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Application.DisplayAlerts = False
On Error Resume Next
Sheets("SPLIT SHEET").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add After:=shDATA
ActiveSheet.Name = "SPLIT SHEET"

i = 1
j = 1
a = 1
b = 1
e = 1
n = 1
y = 1
For r = 1 To shDATA.Cells(Rows.Count, "A").End(xlUp).Row

arrColC = Split(shDATA.Cells(r, 5), ",")
arrColm = Split(shDATA.Cells(r, 13), ",")
arrColw = Split(shDATA.Cells(r, 14), ",")
arrColz = Split(shDATA.Cells(r, 15), ",")
arrCole = Split(shDATA.Cells(r, 16), ",")
arrColh = Split(shDATA.Cells(r, 17), ",")
arrColn = Split(shDATA.Cells(r, 45), ",")
For c = 0 To UBound(arrColC)
Cells(i, 1) = shDATA.Cells(r, 1)
Cells(i, 2) = shDATA.Cells(r, 2)
Cells(i, 3) = shDATA.Cells(r, 3)
Cells(i, 4) = Format(shDATA.Cells(r, 4), "d-mmm-yy")
Cells(i, 5) = arrColC(c)

i = i + 1

For m = 0 To UBound(arrColm)
Cells(j, 6) = shDATA.Cells(r, 6)
Cells(j, 7) = shDATA.Cells(r, 7)
Cells(j, 8) = Format(shDATA.Cells(r, 8), "d-mmm-yy")
Cells(j, 9) = Format(shDATA.Cells(r, 9), "d-mmm-yy")
Cells(j, 10) = shDATA.Cells(r, 10)
Cells(j, 11) = shDATA.Cells(r, 11)
Cells(j, 12) = shDATA.Cells(r, 12)
Cells(j, 13) = arrColm(m)


j = j + 1
Next m

For w = 0 To UBound(arrColw)
Cells(a, 14) = arrColw(w)

a = a + 1

Next w

For z = 0 To UBound(arrColz)
Cells(b, 15) = arrColz(z)


b = b + 1
Next z
For d = 0 To UBound(arrCole)
Cells(e, 16) = arrCole(d)


e = e + 1

Next d

For h = 0 To UBound(arrColh)
Cells(y, 17) = arrColh(h)


y = y + 1


Next h

For k = 0 To UBound(arrColn)

Cells(n, 18) = shDATA.Cells(r, 18)
Cells(n, 19) = shDATA.Cells(r, 19)
Cells(n, 20) = shDATA.Cells(r, 20)
Cells(n, 21) = shDATA.Cells(r, 21)
Cells(n, 22) = shDATA.Cells(r, 22)
Cells(n, 23) = shDATA.Cells(r, 23)
Cells(n, 24) = shDATA.Cells(r, 24)
Cells(n, 25) = shDATA.Cells(r, 25)
Cells(n, 26) = shDATA.Cells(r, 26)
Cells(n, 27) = shDATA.Cells(r, 27)
Cells(n, 28) = shDATA.Cells(r, 28)
Cells(n, 29) = shDATA.Cells(r, 29)
Cells(n, 30) = shDATA.Cells(r, 30)
Cells(n, 31) = shDATA.Cells(r, 31)
Cells(n, 32) = shDATA.Cells(r, 32)
Cells(n, 33) = shDATA.Cells(r, 33)
Cells(n, 34) = shDATA.Cells(r, 34)
Cells(n, 35) = shDATA.Cells(r, 35)
Cells(n, 36) = shDATA.Cells(r, 36)
Cells(n, 37) = shDATA.Cells(r, 37)
Cells(n, 38) = shDATA.Cells(r, 38)
Cells(n, 39) = shDATA.Cells(r, 39)
Cells(n, 40) = shDATA.Cells(r, 40)
Cells(n, 41) = shDATA.Cells(r, 41)
Cells(n, 42) = shDATA.Cells(r, 42)
Cells(n, 44) = Format(shDATA.Cells(r, 44), "d-mmm-yy")

Cells(n, 45) = shDATA.Cells(r, 45)

n = n + 1

Next k

Next c
Next r


End Sub



the problem is that there are some columns missing when I try to run the macro:
1. Last row have missing cells. It get split correctly because of column 13, however it got empty cells from column 1 until 5
2. column 18 is not copied correctly
3. the remaining columns after column 17 is not correct

I think its with the loop somehow, can you please help me out? also there is one column which got comma that I want to exclude and not to include in the split because in this case this column need to be splited after the second column for example:

1. A, B , C, D

need to be

A, B
C, D

thanks a lot for your help

[Wajiha]

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 :)

[Wajiha]

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

A B C
a b l
a c l
a d l
k u
v i
k i
Here's the clearer view of my problem :)

Thanks

[tunderwat]

Thanks Rick! I was running into trouble with something similar and found your macro. All I did was change Const Delimiter As String = ", " to Const Delimiter As String = "|" and the macro helped split up my data! Thank you!

[rpg1966]

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)?