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
> >
Similar Threads
