Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.
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 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)
elements(elementSize - 1) = row.Value
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
'now store the new value
element(i) = row.Value
'stop looking
to'now store the new value
elements(i) = row.Value
'stop looking
distance = Range(Application.Caller.Address).row - rng.row
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
If rng.Rows.Count = 0 Then
'must do something if nothing was selected. I'm not sure what, so just returning what I was sent!
'you should handle appropriately
listUnique = rng
End If
For Each row In rng.Rows
If row.Value <> "" Then
newElement = True
For i = 0 To elementSize - 1 Step 1
If elements(i) = 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 elementSize = 1 Then
'first element
elements(0) = row.Value
Else
'second or nth element, so find it's place
For i = 0 To elementSize - 1
If i = (elementSize - 1) Then
'i index is sitting on the last element in the list and has not been place yet, so stick it there
elements(i) = row.Value
End If
If row.Value < elements(i) Then
'this new value is < (Alphabetically) the current element so
'shift all element down to make room
'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 - 1 To i + 1 Step -1
elements(j) = elements(j - 1)
Next j
'now store the new value
elements(i) = row.Value
'stop looking
Exit For
End If
Next i
End If
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
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
It was written in this post window, and not debugged and you will need to read the caveats in the comments
Open in new window