Excel macro -Split comma separated entries to new rows

Question

I currently have this data in a sheet

Col A   Col B   Col C
1       A       angry birds, gaming
2       B       nirvana,rock,band

What I wa

Answer 1

This will do what you want.

Option Explicit

Const ANALYSIS_ROW As String = "C"
Const DATA_START_ROW As Long = 1

Sub ReplicateData()
    Dim iRow As Long
    Dim lastrow As Long
    Dim ws As Worksheet
    Dim iSplit() As String
    Dim iIndex As Long
    Dim iSize As Long

    'Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook
        .Worksheets("Sheet1").Copy After:=.Worksheets("Sheet1")
        Set ws = ActiveSheet
    End With

    With ws
        lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
    End With


    For iRow = lastrow To DATA_START_ROW Step -1
        iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
        iSize = UBound(iSplit) - LBound(iSplit) + 1
        If iSize = 1 Then GoTo Continue

        ws.Rows(iRow).Copy
        ws.Rows(iRow).Resize(iSize - 1).Insert
        For iIndex = LBound(iSplit) To UBound(iSplit)
            ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
        Next iIndex
Continue:
    Next iRow

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    'Application.ScreenUpdating = True
End Sub

Answer 2

variant using Scripting.Dictionary

Sub ttt()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim x&, cl As Range, rng As Range, k, s
    Set rng = Range([C1], Cells(Rows.Count, "C").End(xlUp))
    x = 1 'used as a key for dictionary and as row number for output
    For Each cl In rng
        For Each s In Split(cl.Value2, ",")
            dic.Add x, Cells(cl.Row, "A").Value2 & "|" & _
                        Cells(cl.Row, "B").Value2 & "|" & LTrim(s)
            x = x + 1
    Next s, cl
    For Each k In dic
        Range(Cells(k, "A"), Cells(k, "C")).Value2 = Split(dic(k), "|")
    Next k
End Sub

source:

result:

Answer 3

If you have a substantial amount of data, you willfind working with arrays beneficial.

Sub Macro2()
    Dim i As Long, j As Long, rws As Long
    Dim inp As Variant, outp As Variant

    With Worksheets("sheet2")
        inp = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "C").End(xlUp)).Value2

        For i = LBound(inp, 1) To UBound(inp, 1)
            rws = rws + UBound(Split(inp(i, 3), ",")) + 1
        Next i

        ReDim outp(1 To rws, 1 To 3)
        rws = 0

        For i = LBound(inp, 1) To UBound(inp, 1)
            For j = 0 To UBound(Split(inp(i, 3), ","))
                rws = rws + 1
                outp(rws, 1) = inp(i, 1)
                outp(rws, 2) = inp(i, 2)
                outp(rws, 3) = Trim(Split(inp(i, 3), ",")(j))
            Next j
        Next i

        .Cells(1, "A").Resize(UBound(outp, 1), UBound(outp, 2)) = outp

    End With
End Sub

Answer 4

This is the answer I have for a two column data. But I want to do it for three columns, Can someone help me here?

You are better off using variant arrays rather than cell loops - they are much quicker code wise once the data sets are meaningful. Even thoug the code is longer :)

This sample below dumps to column C and D so that you can see the orginal data. Change [c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) to [a1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) to dump over your original data

[Updated with regexp to remove any blanks after , ie ", band" becomes "band"] Sub SliceNDice() Dim objRegex As Object Dim X Dim Y Dim lngRow As Long Dim lngCnt As Long Dim tempArr() As String Dim strArr Set objRegex = CreateObject("vbscript.regexp") objRegex.Pattern = "^\s+(.+?)$" 'Define the range to be analysed X = Range([a1], Cells(Rows.Count, "b").End(xlUp)).Value2 Redim Y(1 To 2, 1 To 1000) For lngRow = 1 To UBound(X, 1) 'Split each string by "," tempArr = Split(X(lngRow, 2), ",") For Each strArr In tempArr lngCnt = lngCnt + 1 'Add another 1000 records to resorted array every 1000 records If lngCnt Mod 1000 = 0 Then Redim Preserve Y(1 To 2, 1 To lngCnt + 1000) Y(1, lngCnt) = X(lngRow, 1) Y(2, lngCnt) = objRegex.Replace(strArr, "$1") Next Next lngRow 'Dump the re-ordered range to columns C:D [c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) End Sub

Answer 5

This is not a polished solution, but I need to spend some time with the wife.

But still another way of thinking about it.

This code assumes that the sheet is called Sheet4 and the range that needs to be split is col C.

Dim lastrow As Integer
Dim i As Integer
Dim descriptions() As String

With Worksheets("Sheet4")
    lastrow = .Range("C1").End(xlDown).Row
    For i = lastrow To 2 Step -1
        If InStr(1, .Range("C" & i).Value, ",") <> 0 Then
            descriptions = Split(.Range("C" & i).Value, ",")
        End If
        For Each Item In descriptions
            .Range("C" & i).Value = Item
            .Rows(i).Copy
            .Rows(i).Insert
        Next Item
        .Rows(i).EntireRow.Delete

    Next i
End With