Creating a comma separated list for unique entires

[kreativsoul]

Please let me know how I can achieve the following:

I have this:

NAME	STATE
BOB	PA
BOB	NJ
BOB	DE
TOM	PA
TOM	DE

I need to have this:

NAME	STATE
BOB	PA, NJ, DE
TOM	PA, DE

I have to do this on a very large scale and doing it manually is just not an option... any ideas would be greatly appreciated.

Thanks!

[Richard Buttrey]

Hi,

Assuming the original table is in A1:Bnn, and is sorted on the name then use a couple of helper columns.

C2:
=IF(A2=A1,C1&","&B2,B2)

D2:
=COUNTIF($A2:$A$6,A2)
change the row 6 to suit

Copy C2:D2 down, filter the list on column D for the value 1. Then copy the filtered rows and copy them wherever.

Regards

[Haseeb Avarakkan]

Time for VBA

Insert this VBA oode,

Function CONCATIF(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
            Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
    ' code base by Mike Rickson, MrExcel MVP
    ' used as exactly like SUMIF() with two additional parameters
    ' of delimiter and "no duplicates" as TRUE/FALSE if concatenated values
    ' might include duplicates  ex. =ConcatIf($A$1:$A$10,C1,$B$1:$B$10,", ",True)

Dim i As Long, j As Long

With compareRange.Parent
    Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
End With

If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                    stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(CONCATIF, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    CONCATIF = CONCATIF & Delimiter & CStr(stringsRange.Cells(i, j))
                End If
            End If
        Next j
    Next i
    CONCATIF = Mid(CONCATIF, Len(Delimiter) + 1)
End Function

Then extract unique Name by Advanced Filter & enter them D2 to down. In E2,

=CONCATIF(A:A,D2,B:B,", ",1)

A:A = Name, B:B = State, 1 for exclude duplicate

[kreativsoul]

This is so helpful! Thank you.

Another minor issue.. in some cases, all 50 states will be listed..I dont want to have to spread the cell out to view everything.. this will need to be printed.. is there a way to set it up so that I can put in a hard return after every third value?

So instead of

PA, NJ, DE, IL, NY, AZ

I could get

PA, NJ, DE, (Alt+Enter)
IL, NY, AZ

[Haseeb Avarakkan]

Adjust the column width & use 'Wrap Text'

[kreativsoul]

Using wrap text causes some of the state names to get split up like this:

PA,NJ,D
E,IL,NY
,AZ

[kreativsoul]

can Alt-Enter after every third value be automated?

[JBeaucaire]

Here you go:

Option Explicit

Function CONCATIF(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
            Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
    ' code base by Mike Rickson, MrExcel MVP
    ' used as exactly like SUMIF() with two additional parameters
    ' of delimiter and "no duplicates" as TRUE/FALSE if concatenated values
    ' might include duplicates  ex. =ConcatIf($A$1:$A$10,C1,$B$1:$B$10,", ",True)

Dim i As Long, j As Long, Cnt As Long

With compareRange.Parent
    Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
End With

If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                    stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(CONCATIF, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    If Cnt = 3 Then
                        Cnt = 1
                        CONCATIF = CONCATIF & Delimiter & Chr(10) & CStr(stringsRange.Cells(i, j))
                    Else
                        Cnt = Cnt + 1
                        CONCATIF = CONCATIF & Delimiter & CStr(stringsRange.Cells(i, j))
                    End If
                End If
            End If
        Next j
    Next i
    CONCATIF = Mid(CONCATIF, Len(Delimiter) + 1)
End Function

You will need to still turn on Wrap Text in those cells.

[abousetta]

Maybe try this sub:

Option Explicit

Sub MergeList()

Dim Dic As Object, arrOld, arrNew, r&, x&, LR&

Set Dic = CreateObject("Scripting.Dictionary")

LR = Range("A" & Rows.Count).End(xlUp).Row

  ' Sheet to array
    arrOld = Range("A2:B" & LR)

  ' Scripting Dictionary to create Unique list
    For r = 1 To LR - 1
        Dic.Item(arrOld(r, 1)) = Dic.Item(arrOld(r, 1)) & ", " & arrOld(r, 2)
    Next
    
  ' Merge Keys and Items to form 2D array
    arrNew = Application.Transpose(Array(Dic.Keys, Dic.Items))

  ' Remove leading commas
    For x = 1 To UBound(arrNew)
        arrNew(x, 2) = Mid(arrNew(x, 2), 3)
    Next
    
  ' Array to Sheet
    Range("D2:E" & Dic.Count + 1) = arrNew
  
  ' Header names
    Range("D1:E1") = [{"NAME","STATE"}]
    
  ' Wrap text, set column width and autofit row height
    With Column("E:E")
        .WrapText = True
        .ColumnWidth = 10
    End With
    Rows("2:" & Range("E" & Rows.Count).End(xlUp).Row).EntireRow.AutoFit
End Sub

[jindon]

try

Sub test()
    Dim a, i As Long, x, n As Long
    With Range("a1").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    .Item(a(i, 1)) = a(i, 2)
                Else
                    .Item(a(i, 1)) = _
                    Join$(Array(.Item(a(i, 1)), a(i, 2)), ", ")
                End If
            Next
            x = Application.Transpose(Array(.keys, .items))
            n = .Count
        End With
        With .Offset(, .Columns.Count + 1).Resize(n, 2)
            .CurrentRegion.Clear
            .Value = x
            .Columns.AutoFit
            .CurrentRegion.Borders.Weight = 2
        End With
    End With
End Sub