# VBA Function to Split Cells Giving a Unique List

#### Stephen_IV

##### Well-known Member
Good afternoon, I am looking for someone to help me update my code below. What I would like to do is get list of unique schools. Please see below. Thanks in advance.

Schools 1Schools 2Schools 3Results
Jefferson SchoolJefferson School, Washington SchoolLincoln School, Madison SchoolJefferson School, Washington School, Lincoln School, Madison School
Cleveland School, Eisenhower School, Kennedy SchoolMadison School, Kennedy SchoolCleveland SchoolCleveland School, Eisenhower School, Kennedy School, Madison School
McKinley SchoolTyler SchoolMcKinley School, Jackson SchoolMcKinley School, Tyler School, Jackson School

VBA Code:
``````Function ListUniques(r As Range) As Variant
Dim xcell As Range
Dim dic As New Dictionary
For Each xcell In r
If xcell.Value <> "" Then
dic.Item(xcell.Value) = dic.Item(xcell.Value) + 1
End If
Next xcell
If dic.Count > 0 Then
ListUniques = Join(dic.Keys, ", ")
Else
ListUniques = CVErr(xlErrNA)
End If
End Function
End Sub``````

### Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

#### Fluff

##### MrExcel MVP, Moderator
VBA Code:
``````Function ListUniques(r As Range) As Variant
Dim xcell As Range
Dim Sp As Variant
Dim i As Long

With CreateObject("scripting.dictionary")
For Each xcell In r
Sp = Split(xcell, ", ")
For i = 0 To UBound(Sp)
.Item(Sp(i)) = Empty
Next i
Next xcell
If .Count > 0 Then
ListUniques = Join(.Keys, ", ")
Else
ListUniques = CVErr(xlErrNA)
End If
End With
End Function``````

#### Stephen_IV

##### Well-known Member
Function ListUniques(r As Range) As Variant Dim xcell As Range Dim Sp As Variant Dim i As Long With CreateObject("scripting.dictionary") For Each xcell In r Sp = Split(xcell, ", ") For i = 0 To UBound(Sp) .Item(Sp(i)) = Empty Next i Next xcell If .Count > 0 Then ListUniques = Join(.Keys, ", ") Else ListUniques = CVErr(xlErrNA) End If End With End Function
Fluff thank you so much!!!! I appreciate your help and enjoy your posts!!! Thanks again!!

#### Fluff

##### MrExcel MVP, Moderator
You're welcome & thanks for the feedback.

Replies
8
Views
172
Replies
5
Views
589
Replies
1
Views
433
Replies
2
Views
358

1,130,163
Messages
5,640,512
Members
417,148
Latest member
pe3087te

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back