Stephen_IV
Well-known Member
- Joined
- Mar 17, 2003
- Messages
- 1,168
- Office Version
- 365
- 2019
- Platform
- 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 1 | Schools 2 | Schools 3 | Results |
---|---|---|---|
Jefferson School | Jefferson School, Washington School | Lincoln School, Madison School | Jefferson School, Washington School, Lincoln School, Madison School |
Cleveland School, Eisenhower School, Kennedy School | Madison School, Kennedy School | Cleveland School | Cleveland School, Eisenhower School, Kennedy School, Madison School |
McKinley School | Tyler School | McKinley School, Jackson School | McKinley 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