How to transpose data from one cell separated by commas

[mikey15]

Hi All,

I have a sheet from a manufacturer that tells me which models get which rewards. It looks like this...

[TABLE="width: 500"]
<tbody>[TR]
[TD]MODELS[/TD]
[TD]REWARD[/TD]
[/TR]
[TR]
[TD]X1245, J4541, Y4154[/TD]
[TD]$15[/TD]
[/TR]
[TR]
[TD]A1015, N1522[/TD]
[TD]$20[/TD]
[/TR]
</tbody>[/TABLE]

In order for me to use v-lookup (as I have thousands of line items), How to I transpose this so that each model shows on a different row with the corresponding value? Each model on their list is separated by a comma.
[TABLE="width: 500"]
<tbody>[TR]
[TD]MODEL[/TD]
[TD]REWARD[/TD]
[/TR]
[TR]
[TD]X1245[/TD]
[TD]$15[/TD]
[/TR]
[TR]
[TD]J4541[/TD]
[TD]$15[/TD]
[/TR]
[TR]
[TD]Y4154[/TD]
[TD]$15[/TD]
[/TR]
[TR]
[TD]A1015[/TD]
[TD]$20[/TD]
[/TR]
[TR]
[TD]N1522[/TD]
[TD]$20[/TD]
[/TR]
</tbody>[/TABLE]

Its probably something so simple, but I cant figure it out. Any help would be appreciated.

 

[offthelip]

this code will do it for you:

lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 2))
indi = 1
For i = 2 To lastrow
  txt = inarr(i, 1)
  endtxt = False
   Do While endtxt = False
   fndcomma = InStr(txt, ",")
   If fndcomma > 0 Then
     model = Left(txt, fndcomma - 1)
     Cells(indi, 3) = model
     Cells(indi, 4) = inarr(i, 2)
     indi = indi + 1
     txt = Mid(txt, fndcomma + 1)
   Else
     Cells(indi, 3) = txt
     Cells(indi, 4) = inarr(i, 2)
     indi = indi + 1
     endtxt = True
   Exit Do
   End If
   Loop
Next i
End Sub

 

[sandy666]

try M-code (PowerQuery aka Get&Transform)

[SIZE=1]let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    #"Split Column by Delimiter" = Table.ExpandListColumn(Table.TransformColumns(Source, {{"MODELS", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "MODELS"),
    #"Trimmed Text" = Table.TransformColumns(#"Split Column by Delimiter",{{"MODELS", Text.Trim, type text}})
in
    #"Trimmed Text"[/SIZE]

[Table="width:, class:head"]
[tr=bgcolor:#FFFFFF][td=bgcolor:#5B9BD5]MODELS[/td][td=bgcolor:#5B9BD5]REWARD[/td][td][/td][td=bgcolor:#70AD47]MODELS[/td][td=bgcolor:#70AD47]REWARD[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#DDEBF7]X1245, J4541, Y4154[/td][td=bgcolor:#DDEBF7]

15​

[/td][td][/td][td=bgcolor:#E2EFDA]X1245[/td][td=bgcolor:#E2EFDA]

15​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td]A1015, N1522[/td][td]

20​

[/td][td][/td][td]J4541[/td][td]

15​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td][/td][td][/td][td][/td][td=bgcolor:#E2EFDA]Y4154[/td][td=bgcolor:#E2EFDA]

15​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td][/td][td][/td][td][/td][td]A1015[/td][td]

20​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td][/td][td][/td][td][/td][td=bgcolor:#E2EFDA]N1522[/td][td=bgcolor:#E2EFDA]

20​

[/td][/tr]
[/table]

 

[igold]

How about this...

Sub test()


    Dim lRow As Long, i As Long, x As Long, ct As Long
    Dim lines, arr, fnl, ttl, ttl2
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ttl = Range("A2:A" & lRow)
    For i = 2 To lRow
        ttl = Split(Range("A" & i), ", ")
        ttl2 = ttl2 + UBound(ttl) + 1
    Next
    ReDim fnl(1 To ttl2, 1 To 2)
    arr = Range("A2:B" & lRow)
    For i = LBound(arr) To UBound(arr)
        lines = Split(arr(i, 1), ", ")
            For x = LBound(lines) To UBound(lines)
                fnl(x + 1 + ct, 1) = lines(x)
                fnl(x + 1 + ct, 2) = arr(i, 2)
            Next
            ct = ct + UBound(lines) + 1
    Next
    Range("A2").Resize(UBound(fnl, 1), UBound(fnl, 2)) = fnl
    
End Sub

 

[mikey15]

Thank you so much. This worked like a charm. (sorry for the delayed response, been sick and am finally back to work). Have a great week!

How about this...

Sub test()


    Dim lRow As Long, i As Long, x As Long, ct As Long
    Dim lines, arr, fnl, ttl, ttl2
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ttl = Range("A2:A" & lRow)
    For i = 2 To lRow
        ttl = Split(Range("A" & i), ", ")
        ttl2 = ttl2 + UBound(ttl) + 1
    Next
    ReDim fnl(1 To ttl2, 1 To 2)
    arr = Range("A2:B" & lRow)
    For i = LBound(arr) To UBound(arr)
        lines = Split(arr(i, 1), ", ")
            For x = LBound(lines) To UBound(lines)
                fnl(x + 1 + ct, 1) = lines(x)
                fnl(x + 1 + ct, 2) = arr(i, 2)
            Next
            ct = ct + UBound(lines) + 1
    Next
    Range("A2").Resize(UBound(fnl, 1), UBound(fnl, 2)) = fnl
    
End Sub

 

[igold]

I am glad it worked for you, I was happy to help. Thanks for the feedback!