Text to column but in rows

[Gehree]

Hi All,

First time on this forum and was hoping to get some help. I am trying to do a text to column but in vertical format instead of having it split horizontally.

For example,
My data now looks something like this.

Name	Attributes
Tom	Male, Teen, Tall, Glasses, Black hair
Henry	Male, Adult, Short
Clarissa	Female, Adult
Sam	Male, Child, Short, Black hair
Sarah	Female, Teen, Red hair

<tbody>
</tbody>

I require it to look something like this.

Name	Attributes
Tom	Male
Tom	Teen
Tom	Tall
Tom	Glasses
Tom	Black hair
Henry	Male
Henry	Adult
Henry	Short
Clarissa	Female
Clarissa	Adult
Sam	Male
Sam	Child
Sam	Short
Sam	Black hair
Sarah	Female
Sarah	Teen
Sarah	Red hair

<tbody>
</tbody>

Any help would be greatly appreciated!

Thank you!

 

[Gehree]

You're very welcome...

Hi Tonyyy,

I just ran the code on a larger sample and noticed something strange, while the code does its function, it leaves a few misaligned gaps in between when there are entries without commas or when there are blanks in between. Here's an example of how it looks.

Before I run the code, it looks like this:

Name	Attributes
A	1, 2, 3
B	4, 5
C	6
D	7, 8
E
F	9
G	10, 11

<tbody>
</tbody>

After I run the code, it looks like this.

Name	Attributes
A	1
A	2
A	3
B	4
B	5
	6
C	6
D	7
D	8
E
	9
F	9
G	10
G	11

<tbody>
</tbody>

Any idea why it's like this?

 

[tonyyy]

Gehree,

Ah, you've got bad data, and will need to clean it up before running the macro.

jk!

In future though, please try to post a representative data sample in your initial post. This will help you get a better solution sooner rather than later.

Sub TextToRows()
Application.ScreenUpdating = False
Dim i As Long
Dim arr As Variant

For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    arr = Split(Cells(i, 2).Value, ",")
    If UBound(arr) > 0 Then
        Rows(i + 1 & ":" & i + UBound(arr)).Insert
        Cells(i, 1).Resize(UBound(arr) + 1, 1) = Cells(i, 1).Value
        Cells(i, 2).Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)
    End If
Next i
End Sub

The revised code accommodates single and blank entries.

Cheers,

tonyyy

 

[Gehree]

Gehree,

Ah, you've got bad data, and will need to clean it up before running the macro.

jk!

In future though, please try to post a representative data sample in your initial post. This will help you get a better solution sooner rather than later.

Sub TextToRows()
Application.ScreenUpdating = False
Dim i As Long
Dim arr As Variant

For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    arr = Split(Cells(i, 2).Value, ",")
    If UBound(arr) > 0 Then
        Rows(i + 1 & ":" & i + UBound(arr)).Insert
        Cells(i, 1).Resize(UBound(arr) + 1, 1) = Cells(i, 1).Value
        Cells(i, 2).Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)
    End If
Next i
End Sub

The revised code accommodates single and blank entries.

Cheers,

tonyyy

Hi Tonyyy,

Hahah yes, in fact you are right, I do have bad data and I'm in the midst of cleaning it but I got 7000 entries with 50 columns of attributes to work with so it's taking me a long time to do it. In any case, it's working perfectly now. You have no idea how much time you just saved for me!

Thank you so much!(Again)

Cheers,
Gehree

 

[tonyyy]

You're very welcome, Gehree...