Breaking Out Comma Delimited Column to Row

[scott_n_phnx]

I am trying to expand my code below and need some input. What I need to do is be able to find the cell that has a comma delimited list and break it down into separate rows. So far the code I have uses TextToColumns to separate the comma delimited cell, and then inserts a single blank row, and then copies the item and the date, and then cuts and pastes the second item number down. Since my code is "static" (i.e. only adds a single row), what I am looking for is a way to add the number of new rows, based on how many additional items are broken out. If there are three items in the list, or if there are more, I need to add the proper number of rows. In the examples below, I only have a single line that has three items and so want to be able to add two additional lines beneath. The code I am currently working on is based on it having no more than a single comma and want to expand on that. Any suggestion would be appreciated. (Additionally, I know that there are better ways to do the code, but it is working for me at the moment)

<p></p>
Starting Example:

Book1
	A	B	C
1	Fruit	Date	Item#
2	Apple	20-Apr	21345, 12345
3	Banana	23-Apr	12349
4	Cherry	1-Apr	68901, 88764
5	Dairy	5-Apr	76312, 67890, 43245
Sheet1

Current Result:

Book1
	A	B	C	D	E
1	Fruit	Date	Item#
2	Apple	20-Apr	21345
3	Apple	20-Apr	12345
4	Banana	23-Apr	12349
5	Cherry	1-Apr	68901
6	Cherry	1-Apr	88764
7	Dairy	5-Apr	76312		43245
8	Dairy	5-Apr	67890
Sheet1

Desired End Result:

Book1
	A	B	C
1	Fruit	Date	Item#
2	Apple	20-Apr	21345
3	Apple	20-Apr	12345
4	Banana	23-Apr	12349
5	Cherry	1-Apr	68901
6	Cherry	1-Apr	88764
7	Dairy	5-Apr	76312
8	Dairy	5-Apr	67890
Sheet1

Sub FindComma2()
Application.ScreenUpdating = False
Dim c As Range
Dim LastRow As Long
LastRow = Cells(Rows.Count, 3).End(xlUp).row

For Each c In Range("C1", "C" & LastRow)
    If InStr(1, c.Value, ",", vbTextCompare) Then
        'TextToColumn
            c.Select
            Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(1, 1)), TrailingMinusNumbers:=True
        'Move Data
            c.Select
                Rows(ActiveCell.row + 1).Select
                Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
                c.offSet(0, -2).Select
                Selection.Resize(Selection.Rows.Count, _
                        Selection.Columns.Count + 1).Select
                Selection.Copy Destination:=Selection.offSet(1, 0)
                c.offSet(0, 3).Cut Destination:=c.offSet(1, 2)
                c.offSet(0, 1).Cut Destination:=c.offSet(1, 0)
    End If
Next c
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

I believe the code I posted in my mini-blog article here will do what you want...

<!-- title / author block --> [h=3]Redistribute a Delimited Column Of Data into Separate Rows (Keeping Other Data As Is)[/h]

 

[scott_n_phnx]

Thank you very much. That did what I needed it to do.