CODEWITHSUNDEEP
vbaexcel
Ian
Ian

Reputation: 53

Excel VBA - Comma Delimited Cells to Rows

Looking for VBA code to convert a dynamic table which contains one column of comma separated values into a table with no comma separated values. Columns have titles, and named ranges can be used to identify the table and columns. There could be any number of rows of these values in "Given Data". So in this example there are 4 rows of data, but in practice the data can range from 1 to over 300 rows of data.

Given data ("Sheet1"):

A                   B       C      D
CPN:                MPN:    Price: Text:
CPN1, CPN2, CPN3    MPN1    1.25   Example1
CPN4, CPN6          MPN5    3.50   Example2
CPN7                MPN4    4.20   Example3
CPN8, CPN9          MPN2    2.34   Example4

The result I need is a table on another sheet, lets just say "Sheet2", with rows for each comma separated value in "A" with the corresponding data from the original sheet without deleting the data from the first sheet.

Needed Result ("Sheet2"):

A     B     C      D
CPN:  MPN:  Price: Text:
CPN1  MPN1  1.25   Example1
CPN2  MPN1  1.25   Example1
CPN3  MPN1  1.25   Example1
CPN4  MPN5  3.50   Example2
CPN6  MPN5  3.50   Example2
CPN7  MPN4  4.20   Example3
CPN8  MPN2  2.34   Example4
CPN9  MPN2  2.34   Example4

I have tried modifying the code below from Here but was not able to get it to handle my value types. Any help would be greatly appreciated.

Private Type data
   col1 As Integer
   col2 As String
   col3 As String
End Type

Sub SplitAndCopy()

   Dim x%, y%, c%
   Dim arrData() As data
   Dim splitCol() As String

   ReDim arrData(1 To Cells(1, 1).End(xlDown))

   x = 1: y = 1: c = 1

   Do Until Cells(x, 1) = ""
       arrData(x).col1 = Cells(x, 1)
       arrData(x).col2 = Cells(x, 2)
       arrData(x).col3 = Cells(x, 3)

       x = x + 1
    Loop

    [a:d].Clear

    For x = 1 To UBound(arrData)

        Cells(c, 2) = arrData(x).col2
        splitCol = Split(Mid(arrData(x).col3, 2, Len(arrData(x).col3) - 2), ",")

        ' sort splitCol

        For y = 0 To UBound(splitCol)
            Cells(c, 1) = arrData(x).col1
            Cells(c, 3) = splitCol(y)
            c = c + 1
        Next y

    Next x

End Sub

Upvotes: 5

Views: 12363

Answers (2)

nirmalraj17
nirmalraj17

Reputation: 494

Adapting to @MacroMarc answer, if there are no values after or before comma "," , it will add a new entry which will result in an additional row. So to avoid that do a check of the value separated whether it is empty before writing to the new line.

Public Sub textToColumns()

Set ARange = Range("A:A")
Set BRange = Range("B:B")
Set CRange = Range("C:C")
Set DRange = Range("D:D")

Dim arr() As String

lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Set out = Worksheets.Add
out.Name = "out"
outRow = 2

For i = 2 To lr
    arr = Split(ARange(i), ",")
    For j = 0 To UBound(arr)
        If Len(Trim(arr(j))) > 0 Then
            out.Cells(outRow, 1) = Trim(arr(j))
            out.Cells(outRow, 2) = BRange(i)
            out.Cells(outRow, 3) = CRange(i)
            out.Cells(outRow, 4) = DRange(i)
            outRow = outRow + 1
        End If
    Next j
Next i

End Sub

Upvotes: 0

MacroMarc
MacroMarc

Reputation: 3324

Public Sub textToColumns()

Set ARange = Range("A:A")
Set BRange = Range("B:B")
Set CRange = Range("C:C")
Set DRange = Range("D:D")

Dim arr() As String

lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Set out = Worksheets.Add
out.Name = "out"
outRow = 2

For i = 2 To lr
    arr = Split(ARange(i), ",")
    For j = 0 To UBound(arr)
        out.Cells(outRow, 1) = Trim(arr(j))
        out.Cells(outRow, 2) = BRange(i)
        out.Cells(outRow, 3) = CRange(i)
        out.Cells(outRow, 4) = DRange(i)
        outRow = outRow + 1
    Next j
Next i

End Sub

I didn't do the headers or deal properly with the output sheet but you can see basically what's going on.

Upvotes: 6

Related Questions