VBA Dictionary Unique Items

[Stephen_IV]

Good morning, I need some guidance on how to make a dictionary produce unique Items based on a key. Please see below:

Name Number Name Number AL 1 AL 1, 1, 7 AL 1 Barry 5 AL 7 Bill 1, 1, 6, 6 Barry 5 Ken 3 Bill 1 Paul 4 Bill 1 Sal 6, 12, 13 Bill 6 Sam 3, 3, 4 Bill 6 Ken 3 Paul 4 Sal 6 Sal 12 Sal 13 Sam 3 Sam 3 Sam 4 This is what I am looking for: Name Number Name Number AL 1 AL 1, 7 AL 1 Barry 5 AL 7 Bill 1, 6 Barry 5 Ken 3 Bill 1 Paul 4 Bill 1 Sal 6, 12, 13 Bill 6 Sam 3, 4 Bill 6 Ken 3 Paul 4 Sal 6 Sal 12 Sal 13 Sam 3 Sam 3 Sam 4 This is the Code that I am using: Sub DicUniqueItem() Dim dic As New Dictionary Dim lastrow As Long lastrow = Cells(Rows.Count, "A").End(xlUp).Row For Each xcell In Range("A1:A" & lastrow) If Not dic.Exists(xcell.Value) Then dic.Add xcell.Value, xcell.Offset(0, 1).Value Else dic.Item(xcell.Value) = dic.Item(xcell.Value) & ", " & xcell.Offset(0, 1).Value End If Next Dim k Dim i As Long i = 0 For Each k In dic.Keys i = i + 1 Cells(i, 7).Value = k Cells(i, 8).Value = dic(k) Next End Sub Thanks in advance

 

[Fluff]

How about

Sub DicUniqueItem()
Dim dic As New Dictionary
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For Each xCell In Range("A1:A" & lastrow)
        If Not dic.Exists(xCell.Value) Then
            dic.Add xCell.Value, xCell.Offset(0, 1).Value
        ElseIf InStr(1, " " & dic(xCell.Value) & ",", " " & xCell.Offset(, 1).Value & ",") = 0 Then
            dic.Item(xCell.Value) = dic.Item(xCell.Value) & ", " & xCell.Offset(0, 1).Value
        End If
    Next
   Cells(1, 7).Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.Keys, dic.Items))
End Sub

 

[Stephen_IV]

Sub DicUniqueItem() Dim dic As New Dictionary Dim lastrow As Long lastrow = Cells(Rows.Count, "A").End(xlUp).Row For Each xCell In Range("A1:A" & lastrow) If Not dic.Exists(xCell.Value) Then dic.Add xCell.Value, xCell.Offset(0, 1).Value ElseIf InStr(1, " " & dic(xCell.Value) & ",", " " & xCell.Offset(, 1).Value & ",") = 0 Then dic.Item(xCell.Value) = dic.Item(xCell.Value) & ", " & xCell.Offset(0, 1).Value End If Next Cells(1, 7).Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.Keys, dic.Items)) End Sub

Thanks Fluff! I really appreciate your help and guidance. That worked perfectly!

 

[Fluff]

You're welcome & thanks for the feedback.

 

[Carlos1019]

Hi, I need help on a macro I'm doing.

I need it to open several .csv files in thisworkbook.path.

A moment ago it was working and now I'm getting an error.

Can you please help me?

Thanks in advance!

 

[Fluff]

As this is a totally different question, you need to start a thread of your own. Thanks

 

[Peter_SSs]

@Stephen_IV
A couple of comments/suggestions.

Perhaps there is a particular need for vba but since you have Excel 365 it can easily be done by formula.

Stephen_IV.xlsm
	A	B	C	D	E	F	G	H
1	Name	Number					Name	Number
2	AL	1					AL	1, 7
3	AL	1					Barry	5
4	AL	7					Bill	1, 6
5	Barry	5					Ken	3
6	Bill	1					Paul	4
7	Bill	1					Sal	6, 12, 13
8	Bill	6					Sam	3, 4
9	Bill	6
10	Ken	3
11	Paul	4
12	Sal	6
13	Sal	12
14	Sal	13
15	Sam	3
16	Sam	3
17	Sam	4
Sheet1

Cell Formulas
Range	Formula
G2:G8	G2	=UNIQUE(A2:A17)
H2:H11	H2	=TEXTJOIN(", ",1,UNIQUE(FILTER(B$2:B$17,A$2:A$17=G2,"")))
Dynamic array formulas.

If vba is required then since you are using a dictionary to get the unique names, you can also use the dictionary idea to get unique numbers.
It may not be an issue with your data but this can also be a speed issue as continually joining strings in the dictionary items can get sluggish if the strings get at all long.
In any case, if you are interested, here is a method using a 'dictionary of dictionaries' that I believe does the same job.

Sub DicUniqueItem_v2()
  Dim dic As New Dictionary
  Dim i As Long
  Dim a As Variant, ky As Variant

  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value2
  For i = 1 To UBound(a)
    If Not dic.Exists(a(i, 1)) Then dic.Add (a(i, 1)), CreateObject("Scripting.Dictionary")
    dic(a(i, 1))(a(i, 2)) = Empty
  Next i
  For Each ky In dic.Keys
    dic.Item(ky) = Join(dic.Item(ky).Keys, ", ")
  Next ky
  Cells(1, 7).Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.Keys, dic.Items))
End Sub

 

[Stephen_IV]

Thanks Peter_SSs I am always interested in learning. I originally thought of a double dictionary but learned something new from Fluff. I appreciate your help and assistance!!!