Macro to concatenate data

[eduzs]

Hi there,

(all fictitious)

Suppose that I have a worksheet with names, date and prizes won at those dates, as they appear in the worksheet.

I need a VBA code that concatenate these data in a single row per person, listing the person name, the dates and the prizes wons on each unique date.

The list of names is in alphabetical order and then in date order, the prizes are unique.

For example:

NAME	DATE	PRIZE
ANN	2018/10/1	X
BILL	2018/10/1	Y
BILL	2018/11/4	Z
BILL	2018/11/4	W

<tbody>
</tbody>

The result rows will be:

"ANN: 2018/10/1 (X)"
"BILL: 2018/10/1 (Y), 2018/11/4 (Z,W)"

One person name will be listed once one row per person.

Each unique date that the person won prizes will be listed in the same name line, with each type of prize won between ().

Any ideas? Thanks.

 

[eduzs]

Thanks. There's a way to adapt the code from Peter? It's more suitable for my needs.

 

[Rick Rothstein]

Thanks. There's a way to adapt the code from Peter? It's more suitable for my needs.

I think I have correctly modified Peter's code...

[table="width: 500"]
[tr]
	[td]Sub Prizes_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Range("A1", Range("B" & Rows.Count).End(xlUp).Offset(1)).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 2 To UBound(a)
    If a(i, 1) = a(i - 1, 1) Then
      b(k, 2) = b(k, 2) & IIf(a(i, 2) = a(i - 1, 2), ", ", ", " & a(i, 2))
    Else
      If k > 0 Then b(k, 2) = b(k, 2)
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
    End If
  Next i
  With Range("E1:F1")
    .Value = Array("Name", "Prize List")
    .Offset(1).Resize(k - 1).Value = b
    .EntireColumn.AutoFit
  End With
End Sub[/td]
[/tr]
[/table]

 

[eduzs]

Works fine Rick! Thank you.
I mixed the codes, so my macro is able to run both with 2 or 3 data columns.

 

[Peter_SSs]

I would trim it down like this.

Sub Prizes_No_Dates()
  Dim a As Variant
  Dim i As Long, k As Long
  
  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  For i = 2 To UBound(a)
    If a(i, 1) = a(i - 1, 1) Then
      a(k, 2) = a(k, 2) & ", " & a(i, 2)
    Else
      k = IIf(k = 0, 2, k + 1)
      a(k, 1) = a(i, 1): a(k, 2) = a(i, 2)
    End If
  Next i
  Range("E1:F1").Resize(k).Value = a
  Columns("E:F").AutoFit
End Sub