CODEWITHSUNDEEP
excelexcel-formulavba
Apriljuly
Apriljuly

Reputation: 51

Split 1 column content(comma separated) into multiple rows in EXCEL

I have some data like below, 

UserID  | UserName  | skills | 
1       | John      | 1,2,3,4,5|     
2       | Mary      | 1,2,3|

Can anyone help me with a macro which can change the data structure into: 

UserID  | UserName  | skills | 
1       | John      | 1 |  
1       | John      | 2 |  
1       | John      | 3 | 
1       | John      | 4 | 
1       | John      | 5 |  
2       | Mary      | 1 |     
2       | Mary      | 2 |
2       | Mary      | 3 |

Thank you!

Upvotes: 1

Views: 2971

Answers (3)

MakeCents
MakeCents

Reputation: 764

This method looks at each row and then inserts rows and spreads the information in place, overwriting. But I think I like KazJaw's better.

enter image description here

enter image description here

Sub Spread_Skills()
'Spread string of skills down spreadsheet for each UserID
'Application.ScreenUpdating = False 'Uncomment for large files
    i = 2
    Do While Not IsEmpty(Cells(i, 1)) 'as long as there is a userid do this
        If Not InStr(Cells(i, 3), ",") = 0 Then 'if there is a comma, more than one skill, do this
            UserId = Cells(i, 1) 'gather info
            UserName = Cells(i, 2) 'gather info
            adn = Len(Cells(i, 3)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 3), ",", "")) 'count number of skills
            Rows(i + 1 & ":" & i + adn).Select 'go to the next row
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'Insert a row for each skill-1
            temp = Mid(Cells(i, 3), Application.WorksheetFunction.Find(",", Cells(i, 3), 1) + 1, Len(Cells(i, 3))) 'asign string of skills
            Cells(i, 3) = Left(Cells(i, 3), Application.WorksheetFunction.Find(",", Cells(i, 3), 1) - 1) 'make the first row the first skill
            For o = i + 1 To i + adn 'for each additional skill do this
                If Not InStr(temp, ",") = 0 Then 'if it isn't the last skill do this
                    ntemp = Left(temp, Application.WorksheetFunction.Find(",", temp, 1) - 1) 'slice
                    temp = Mid(temp, Application.WorksheetFunction.Find(",", temp, 1) + 1, Len(temp)) 'reasign remaining skills
                Else: 'if it is the last skill do this
                    ntemp = temp
                End If
                Cells(o, 1) = UserId 'enter data
                Cells(o, 2) = UserName 'enter data
                Cells(o, 3) = ntemp 'enter data
                Next o 'next row in skill range
        End If
        i = i + adn + 1 'go to the next userid
    Loop
'Application.ScreenUpdating = true 'Uncomment for large files
End Sub

Upvotes: 0

Kazimierz Jawor
Kazimierz Jawor

Reputation: 19067

I've just had a minute to make this code for you. Some additional assumptions in comments below. 

Sub qTest()
'assumptions:
'1. you need to select top left cell of your original data table, _
    i.e. cell UserId
'2. table will be created to the right- there must be empty area

'select UserID cell
    Dim i As Long
    Dim tmpSkills As Variant
    Dim tmpRow As Long
    Dim iSkills As Long
    Dim tmpArray As Variant
        tmpArray = Selection.CurrentRegion

'copying
    Selection.Resize(1, 3).Copy Selection.Offset(0, 4)

    For i = 2 To UBound(tmpArray)

        tmpSkills = Split(tmpArray(i, 3), ",")
        iSkills = UBound(tmpSkills) +1

        'skils        
        Selection.Offset(1 + tmpRow, 6).Resize(iSkills, 1) = Application.Transpose(tmpSkills)
        'UserId
        Selection.Offset(1 + tmpRow, 5).Resize(iSkills, 1) = tmpArray(i, 2)
        'UserName
        Selection.Offset(1 + tmpRow, 4).Resize(iSkills, 1) = tmpArray(i, 1)

        tmpRow = tmpRow + iSkills

    Next
End Sub

Picture presenting data before (on the left) and after (on the right). UserID cell should be selected before you run macro.

enter image description here

Upvotes: 1

Derek Cheng
Derek Cheng

Reputation: 525

You can use the text to columns function in Excel.

Please refer to this link: Microsoft Support

Upvotes: 1

Related Questions