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...

MODELS	REWARD
X1245, J4541, Y4154	$15
A1015, N1522	$20

<tbody>
</tbody>

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.

MODEL	REWARD
X1245	$15
J4541	$15
Y4154	$15
A1015	$20
N1522	$20

<tbody>
</tbody>

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]

MODELS	REWARD		MODELS	REWARD
X1245, J4541, Y4154	15​		X1245	15​
A1015, N1522	20​		J4541	15​
			Y4154	15​
			A1015	20​
			N1522	20​

 

[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!