Give each value in a comma-delimited column its own row

[Matt]

say i have a sheet with 2 columns. one is called id, the other is
called category. lets say in id i have the value : 1 and in category
i have the value: 3,6,7,9

like this:

ID CATEGORY
1 3,6,7,9

how do i split it out so that each value in the category list has its
own row and shares the id? basically i want to make it look like this

ID CATEGORY
1 3
1 6
1 7
1 9

but i have a lot to do and don't want to do it manually.

thanks in advance for any help given.

Matt

 

[Frank Kabel]

Hi
try:
Sub create_rows()
Dim source_wks As Worksheet
Dim target_wks As Worksheet
Dim lastrow As Long
Dim row_index As Long
Dim target_row As Long
Dim vRes
Dim i As Integer
Application.ScreenUpdating = False
Set source_wks = Worksheets("sheet1")
Set target_wks = Worksheets("sheet2")
lastrow = source_wks.Cells(Rows.Count, 1).End(xlUp).Row
target_row = 1
For row_index = 1 To lastrow
With Cells(row_index, 2)
If .Value <> "" Then
vRes = Split(.Value, ",")
For i = 0 To UBound(vRes)
target_wks.Cells(target_row, 2).Value = vRes(i)
target_wks.Cells(target_row, 1).Value = _
.Offset(0, -1).Value
target_row = target_row + 1
Next
End If
End With
Next
Application.ScreenUpdating = True

End Sub

 

[Dave Peterson]

Since you only have two columns, I'd use excel's Data|text to columns to
separate each value in column B into its own cell (C:IV???).

Then you could use a series of copy|pastespecial transposes (after inserting the
rows).

As a macro:

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim RngToCopy As Range

Set wks = Worksheets("sheet1")

With wks
.Range("b:b").TextToColumns Destination:=.Range("B1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False

FirstRow = 1 'no header rows
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

For iRow = LastRow To FirstRow Step -1
Set RngToCopy = .Range(.Cells(iRow, "B"), _
.Cells(iRow, .Columns.Count).End(xlToLeft))
If RngToCopy.Cells.Count = 1 Then
'do nothing
Else
.Rows(iRow + 1).Resize(RngToCopy.Cells.Count - 1).Insert
.Cells(iRow + 1, "A").Resize(RngToCopy.Cells.Count - 1).Value _
= .Cells(iRow, "A").Value
With RngToCopy
.Offset(0, 1).Resize(1, .Cells.Count - 1).Copy
.Cells(1, 1).Offset(1, 0).PasteSpecial Transpose:=True
End With
End If
Next iRow
.Range("c:IV").Clear
End With
End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm