Quite a puzzler - Concatenate for unique entries

**despacos** · 04-15-2011, 09:13 AM

Hello,

Presenting below quite a puzzler

I have the following info on 3 columns; i am really curios if i can get the result mentioned below (meaning put the info on column 3 in a single cell where the first two cells have the same info - meaning for the unique two first column which i already have i need to write A,B,C or D,E,F next to them, as in the result)

Is it really possible? Couldn't figure out any solution for this

ARRAY:

Word 1|Opt 1|A
Word 1|Opt 1|B
Word 1|Opt 1|C
Word 2|Opt 2|D
Word 2|Opt 2|E
Word 2|Opt 2|F

Result
Word 1|Opt 1|A, B, C
Word 2|Opt 2|D, E, F

**jwright650** · 04-15-2011, 09:39 AM

Is this what you are trying to do? See the formula in the cells in Column E

**pike** · 04-15-2011, 09:47 AM

Hi despacos
welcome to the forum,

on the sample...

Sub ptest()
    Dim a, b(), i!, n!
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 3)
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 3)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = vbTextCompare
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    b(n, 1) = a(i, 1)
                    b(n, 2) = a(i, 2)
                    .Add a(i, 1), n
                End If
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) & IIf(b(.Item(a(i, 1)), 3) <> "", ", ", " ") & a(i, 3)
            Next
        End With
        .ClearContents
    End With
    Range("a1").Resize(n, 3).Value = b
End Sub