VBA Function to Split Cells Giving a Unique List

Stephen_IV

Well-known Member
Joined
Mar 17, 2003
Messages
988
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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
Joined
Jun 12, 2014
Messages
56,882
Office Version
  1. 365
Platform
  1. Windows
How about
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
 
Solution

Stephen_IV

Well-known Member
Joined
Mar 17, 2003
Messages
988
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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
Joined
Jun 12, 2014
Messages
56,882
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Top