It was written in this post window, and not debugged and you will need to read the caveats in the comments

```
Function listUnique(rng As Range) As Variant
Dim row As Range
Dim elements() As String
Dim elementSize As Integer
Dim newElement As Boolean
Dim i As Integer
Dim j as integer
Dim distance As Integer
Dim result As String
elementSize = 0
newElement = True
For Each row In rng.Rows
If row.Value <> "" Then
newElement = True
For i = 1 To elementSize Step 1
If elements(i - 1) = row.Value Then
newElement = False
End If
Next i
If newElement Then
elementSize = elementSize + 1
ReDim Preserve elements(elementSize - 1)
'find sorted location and stick it there in order
'if 0 based array you will need to adjust with -1 or something
for i=1 to elementSize
if row.Value<elements(i) then
'this new value is < (Alphabetically) the current element so
'shift all element down to make room
'if 0 based array you will need to adjust with -1 or something
'you will also need code to make sure this isn't the only element and that i isn't on the last
'element--in that case no shifting is needed
for j = elementsize to i+1 Step -1
elements(j)=elements(j-1)
next j
'now store the new value
element(i)=Row.Value
'stop looking
Exit For
end if
next i
End If
End If
Next
distance = Range(Application.Caller.Address).row - rng.row
If distance < elementSize Then
result = elements(distance)
listUnique = result
Else
listUnique = ""
End If
End Function
```