Concatenate unique items

[Robin]

I have some data in two columns like this:
001 blue
001 blue
001 red
001 green
002 blue
003 green
003 green
004 red
004 green

What I need to do is show the data on another sheet like this:
001 blue, red, green
002 blue
003 green
004 red, green

So I need to concatenate the unique items in the list for each id in the
first column. I would like to do this via a macro because I will have to do
it each month on a different workbook. Any help is appreciated!

 

[Mike H.]

This assumes your data is in columns 1 and 2. If not, you'll have to modify
accoringly:


Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet

Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
Next
End If
X = X + 1
Loop

Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Code"
Cells(1, 2).Value = "Colors Found"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")



End Sub

 

[Robin]

That didn't quite work. It took my original example list and did this:

Code Colors Found
001 blue, blue, red, green
002 blue
003 green, green
003 green
003 green
003 green
004 red, green
004 red
004 red
004 red
004 red
004 red
004 green
004 green
004 green
004 green
004 green
004 green

 

[Robin]

If it matters, in my real-life work, the first column will be social security
numbers... I just used the other list for example. Thanks much!

 

[JMB]

Another possible approach. Change the source and destination ranges as
needed (or modify to have the macro create a new sheet and put the results in
the new sheet if you don't already have a destination sheet set up). I also
assume your source data is in 2 adjacent columns. And, I assume your data
does not already have commas.

Sub test()
Dim colUnique As Collection
Dim rngData As Range
Dim rngDest As Range
Dim rngcell As Range
Dim i As Long
Dim lngCount As Long

Set colUnique = New Collection
Set rngSource = Sheet1.Range("A1:B9") '<<CHANGE
Set rngDest = Sheet2.Range("A1") '<<<CHANGE

On Error Resume Next
For Each rngcell In rngSource.Columns(1).Cells
colUnique.Add CStr(rngcell.Text & "," & rngcell.Offset(0, 1).Value), _
CStr(rngcell.Value & "," & rngcell.Offset(0, 1).Value)
Next rngcell
On Error GoTo 0

For i = 1 To colUnique.Count
If i > 1 Then
If Split(colUnique(i), ",")(0) = Split(colUnique(i - 1), ",")(0) Then
rngDest(1 + lngCount, 2).Value = rngDest(1 + lngCount, 2).Value & _
", " & Split(colUnique(i), ",")(1)
Else
lngCount = lngCount + 1
With rngDest(1 + lngCount, 1)
.NumberFormat = "@"
.Value = Split(colUnique(i), ",")(0)
.Offset(0, 1).Value = Split(colUnique(i), ",")(1)
End With
End If
Else
With rngDest
.NumberFormat = "@"
.Value = Split(colUnique(i), ",")(0)
.Offset(0, 1).Value = Split(colUnique(i), ",")(1)
End With
End If
Next i

End Sub

 

[Robin]

That works GREAT! Thank you sooo much!

Another possible approach. Change the source and destination ranges as
needed (or modify to have the macro create a new sheet and put the results in
the new sheet if you don't already have a destination sheet set up). I also
assume your source data is in 2 adjacent columns. And, I assume your data
does not already have commas.

Sub test()
Dim colUnique As Collection
Dim rngData As Range
Dim rngDest As Range
Dim rngcell As Range
Dim i As Long
Dim lngCount As Long

Set colUnique = New Collection
Set rngSource = Sheet1.Range("A1:B9") '<<CHANGE
Set rngDest = Sheet2.Range("A1") '<<<CHANGE

On Error Resume Next
For Each rngcell In rngSource.Columns(1).Cells
colUnique.Add CStr(rngcell.Text & "," & rngcell.Offset(0, 1).Value), _
CStr(rngcell.Value & "," & rngcell.Offset(0, 1).Value)
Next rngcell
On Error GoTo 0

For i = 1 To colUnique.Count
If i > 1 Then
If Split(colUnique(i), ",")(0) = Split(colUnique(i - 1), ",")(0) Then
rngDest(1 + lngCount, 2).Value = rngDest(1 + lngCount, 2).Value & _
", " & Split(colUnique(i), ",")(1)
Else
lngCount = lngCount + 1
With rngDest(1 + lngCount, 1)
.NumberFormat = "@"
.Value = Split(colUnique(i), ",")(0)
.Offset(0, 1).Value = Split(colUnique(i), ",")(1)
End With
End If
Else
With rngDest
.NumberFormat = "@"
.Value = Split(colUnique(i), ",")(0)
.Offset(0, 1).Value = Split(colUnique(i), ",")(1)
End With
End If
Next i

End Sub

 

[JMB]

glad to help

That works GREAT! Thank you sooo much!

 

[Mike H.]

I see you have a working solution, but the only thing wrong with the one I
gave you should you ever need it is to move the first "next" line up 6 lines.
Then you get the desired results:

Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet

Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop

Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Code"
Cells(1, 2).Value = "Colors Found"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")



End Sub

 

[Robin]

You are correct - that worked well, too. Thanks!