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:

[TABLE="class: grid, width: 50"]
<tbody>[TR]
[TD]NAME[/TD]
[TD]DATE[/TD]
[TD]PRIZE[/TD]
[/TR]
[TR]
[TD]ANN[/TD]
[TD]2018/10/1[/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]BILL[/TD]
[TD]2018/10/1[/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD]BILL[/TD]
[TD]2018/11/4[/TD]
[TD]Z[/TD]
[/TR]
[TR]
[TD]BILL[/TD]
[TD]2018/11/4[/TD]
[TD]W[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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.

 

[Rick Rothstein]

How to concatenate all the result in two columns (name in "A", result in "B"), instead using diferent columns for each unique "B" column dates? (using "; " instead of the next column).

Does the above mean you want to replace the existing data with the newly processed data?

Are the two columns Names for the first and Concatenated Text values for the second?

 

[eduzs]

The code from spirarain works fine, however, when a person has more than one diferent date (column "B") he writes the result in as many columns as the unique dates from a person. Which requires another concatenation step at the end of the process.

 

[Peter_SSs]

Assuming that ..
- the original data is in A1:Cxx of the active sheet
- column B are actual dates (formatted as "yyyy/m/d")
- data sorted as you described
- results can go in the same sheet to the right of the original data
.. then try this with a copy of your workbook.

Sub PrizeList()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  Dim nm As String, dt As String
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("C" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    nm = a(i, 1)
    dt = Format(a(i, 2), "yyyy/m/d")
    If d.Exists(nm) Then
      If InStr(1, d(nm), dt) Then
        d(nm) = Left(d(nm), Len(d(nm)) - 1) & "," & a(i, 3) & ")"
      Else
        d(nm) = d(nm) & ", " & dt & " (" & a(i, 3) & ")"
      End If
    Else
      d(nm) = dt & " (" & a(i, 3) & ")"
    End If
  Next i
  With Range("E1:F1")
    .Value = Array("Name", "Prize List")
    .Offset(1).Resize(d.Count).Value = Application.Transpose(Array(d.Keys, d.Items))
    .EntireColumn.AutoFit
  End With
End Sub

Book1
	A	B	C	D	E	F
1	NAME	DATE	PRIZE		Name	Prize List
2	ANN	2018/10/1	X		ANN	2018/10/1 (X)
3	BILL	2018/10/1	Y		BILL	2018/10/1 (Y), 2018/11/4 (Z,W)
4	BILL	2018/11/4	Z
5	BILL	2018/11/4	W
Prizes

 

[Peter_SSs]

Actually, given the sorting of the original data, perhaps just this.

Sub Prizes_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Range("A1", Range("C" & 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), ", ", "), " & Format(a(i, 2), "yyyy/m/d") & " (") & a(i, 3)
    Else
      If k > 0 Then b(k, 2) = b(k, 2) & ")"
      k = k + 1
      b(k, 1) = a(i, 1): b(k, 2) = Format(a(i, 2), "yyyy/m/d") & " (" & a(i, 3)
    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

 

[eduzs]

Great! Thanks! Works like a charm.
It's the kind of code that is not long, but it needs a lot of logical reasoning.

 

[Peter_SSs]

Great! Thanks! Works like a charm.

You are very welcome. Thanks for letting us know.

 

[eduzs]

Hi there!
Is that possible to adapt this code to also works with only 2 columns of data (names and dates (no prizes))??
Thanks

 

[Peter_SSs]

Hi there!
Is that possible to adapt this code to also works with only 2 columns of data (names and dates (no prizes))??
Thanks

Can you either ..
a) Confirm what the expected results would be for that previous sample data, or
b) Provide a new set of representative sample data and the expected results?

 

[eduzs]

Sample table:

[TABLE="width: 100"]
<tbody>[TR]
[TD]MARY[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]MARY[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]JOE[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]PAUL[/TD]
[TD]Z[/TD]
[/TR]
[TR]
[TD]PAUL[/TD]
[TD]Y[/TD]
[/TR]
</tbody>[/TABLE]

Expected result:

[TABLE="width: 100"]
<tbody>[TR]
[TD]MARY[/TD]
[TD]A, D[/TD]
[/TR]
[TR]
[TD]JOE[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]PAUL[/TD]
[TD]Z, Y[/TD]
[/TR]
</tbody>[/TABLE]

Thanks!

 

[Rick Rothstein]

Sample table:

[TABLE="width: 100"]
<tbody>[TR]
[TD]MARY[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]MARY[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]JOE[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]PAUL[/TD]
[TD]Z[/TD]
[/TR]
[TR]
[TD]PAUL[/TD]
[TD]Y[/TD]
[/TR]
</tbody>[/TABLE]

Expected result:

[TABLE="width: 100"]
<tbody>[TR]
[TD]MARY[/TD]
[TD]A, D[/TD]
[/TR]
[TR]
[TD]JOE[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]PAUL[/TD]
[TD]Z, Y[/TD]
[/TR]
</tbody>[/TABLE]

Here is one way to produce that expect result table (output to Columns D and E)...

[table="width: 500"]
[tr]
	[td]Sub ListWithoutPrizes()
  Dim LastRow As Long, Ar As Range
  Range("A1").CurrentRegion.Copy Range("D1")
  LastRow = Cells(Rows.Count, "D").End(xlUp).Row
  Application.ScreenUpdating = False
  With Range("D2:D" & LastRow)
    .Value = Evaluate("IF(D2:D" & LastRow & "=D1:D" & LastRow - 1 & ","""",D2:D" & LastRow & ")")
    With .SpecialCells(xlBlanks)
      For Each Ar In .Areas
        Ar(1).Offset(-1, 1) = Join(Application.Transpose(Ar(1).Offset(-1, 1).Resize(Ar.Count + 1)), ", ")
      Next
      Intersect(.EntireRow, Columns("D:E")).Delete xlShiftUp
    End With
  End With
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]