Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
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! |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
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 "Mike H." wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
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! "Mike H." wrote: 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
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" wrote: 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! "Mike H." wrote: 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
That works GREAT! Thank you sooo much!
"JMB" wrote: 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" wrote: 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! "Mike H." wrote: 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
glad to help
"Robin" wrote: That works GREAT! Thank you sooo much! "JMB" wrote: 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" wrote: 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! "Mike H." wrote: 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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
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 |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Concatenate unique items
You are correct - that worked well, too. Thanks!
"Mike H." wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Concatenate unique values among duplicates | Excel Worksheet Functions | |||
How do I de-concatenate items separated by commas! | Excel Discussion (Misc queries) | |||
Concatenate Unique advanced filter results | Excel Discussion (Misc queries) | |||
Concatenate Unique Entries | Excel Discussion (Misc queries) | |||
Adding Items to a ListBox-Unique Items Only | Excel Programming |