• Status: Solved
• Priority: Medium
• Security: Public
• Views: 351

# Modify Excel VBA Function to Include Sorting

I found this function that works exactly as I needed to return unique value on a column range.  Is it possible to modify this working function to also sort the unique list in alphabetical order?

Example List in Range
Zac Efron
Andrew Lincoln
Bardie Doll
Andrew Lincoln
Zac Efron

Example List using Function
Zac Efron
Andrew Lincoln
Bardie Doll

Example List using Function and Sort alphabethically
Andrew Lincoln
Bardie Doll
Zac Efron

``````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

If distance < elementSize Then
result = elements(distance)
listUnique = result
Else
listUnique = ""
End If
End Function
``````
0
KANEDA 0149
• 4
• 3
• 2
• +1
1 Solution

Commented:
This should give you the general idea of "sort as you go"
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

If distance < elementSize Then
result = elements(distance)
listUnique = result
Else
listUnique = ""
End If
End Function
``````
0

Author Commented:
Hi SStory, thank you for the quick response.  I applied the modified function and it returned a compile error.  In reviewing the following I changed it from
``````'now store the new value
element(i) = row.Value
'stop looking
``````
to
``````'now store the new value
elements(i) = row.Value
'stop looking
``````

which fixed the compile error but when using the function in the worksheet cell it returned all #VALUE! errors.  Any ideas?
0

Commented:
Why not use the advancedfilter to get the unique values and then use Excel's sort?  It seems the simplest approach.
0

Finance AnalystCommented:
I often use a manual approach for this.

1) Copy and paste the whole list into a new sheet with at least one blank cell or the header above it.
2) Sort the new version of the list into alphabetical order.
3) Alongside the first entry of the data enter formula  =A1=A2  ie comparing the first two entries. The result will be TRUE (same values) or FALSE (Different values). Copy down for the whole list.
4) Apply an AutoFilter to this list and show only the TRUE values.
5) Highlight the list and Delete rows, accept warning message about deleting whole row (that's why we went to a new sheet) and then disable AutoFilter.
6) The formulas will now be showing as #Ref because the cells to which they were referring have been deleted so just delete the formulas.
7) You now have sorted list of unique entries.

Thanks
Rob H
0

Author Commented:
Thank you aikimark and Rob H. for the suggestion.  The reason I am looking to get this in VBA was simply because the workbook is meant to be used by inexperience Excel users and shared among multi individuals.  The goal was to make a tab where 1 group was the "inputter" of data and another tab for the 2nd group simply view the "iput" data from another tab keeping the original untouched.

I agree with you both that it could be accomplished manually.  I was just trying to automate the data analysis and make it seemless for the end user to review.
0

Commented:
@KANEDA 0149

Do you need to replace the original range or make your new list reside in a different range?
Does the sorting affect any of the other cells on the same lines in the target worksheet?

The filtering and sorting can be automated with a couple of lines of VBA code.  I was waiting for details from you before posting any code.
0

Author Commented:
Hi aikimark.   I would like to make anew list that resides in a different range and yes the sorting will affect another worksheet from the target worksheet.  In the attached Sample workbook, you will see I want the "unique" sorted values in the tab called "List" (column C).  This unique list is then used in two (2) other worksheets; (1) Summary and (2) Returned Mailing.

In the Returned Mailing worksheet, it is only used in cell D2 as a unique validation list that dynamically changes as new or removed items from the "Facilities Tab" worksheet.

In the Summary worksheet, it is used as a cell reference to pull the unique values to show a summary for the items identified on the "Returned Mailing" worksheet.  Hope this make sense.

Sample-Workbook.xlsm
0

Finance AnalystCommented:
Another option for getting a sorted re-useable unique list is to generate a Pivot Table on your original data-set.

if the number of columns in the pivot isn't going to change then you can add formulas alongside it using the contents of the pivot as a reference.

Thanks
Rob H
0

Commented:
Please replace the code I gave you with what is shown below. Read the code comments to know the caveats. I tested by making a Macro that called this function with the current selection. I assumed that this is what you are doing.  So I selected a list of 8 items in column A and ran the macro.

I debugged and tested the code (below) with a disorganized list.  Debugging at the line:

``````distance = Range(Application.Caller.Address).row - rng.row
``````

and adding a Watch to the elements array showed that all were sorted and unique. What the distance= line is supposed to do, I do not know.

``````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

If distance < elementSize Then
result = elements(distance)
listUnique = result
Else
listUnique = ""
End If
End Function
``````

The distance line uses your:
code and that is an uninitialized object.  Since I don't know the intended goal with that code, I'm not sure how to debug it. I do however, have your list unique and sorted before that point.
0

Author Commented:
Thank you SStory, that did it and it works perfectly!
0

Commented:
0
Question has a verified solution.

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.