Solved

Modify Excel VBA Function to Include Sorting

Posted on 2014-12-12
11
293 Views
Last Modified: 2014-12-15
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

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

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

Open in new window

0
Comment
Question by:KANEDA 0149
  • 4
  • 3
  • 2
  • +1
11 Comments
 
LVL 25

Expert Comment

by:SStory
ID: 40496991
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

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

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

Open in new window

0
 

Author Comment

by:KANEDA 0149
ID: 40497128
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

Open in new window

to
'now store the new value
                           elements(i) = row.Value
                            'stop looking

Open in new window


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

Expert Comment

by:aikimark
ID: 40497150
Why not use the advancedfilter to get the unique values and then use Excel's sort?  It seems the simplest approach.
0
 
LVL 31

Expert Comment

by:Rob Henson
ID: 40500105
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 Comment

by:KANEDA 0149
ID: 40500328
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
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 45

Expert Comment

by:aikimark
ID: 40500418
@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 Comment

by:KANEDA 0149
ID: 40500514
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.

Thanks again for your help!
Sample-Workbook.xlsm
0
 
LVL 31

Expert Comment

by:Rob Henson
ID: 40500560
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
 
LVL 25

Accepted Solution

by:
SStory earned 500 total points
ID: 40500610
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

Open in new window


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

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

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

Open in new window


The distance line uses your:
Application.Caller.Address
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 Closing Comment

by:KANEDA 0149
ID: 40500625
Thank you SStory, that did it and it works perfectly!
0
 
LVL 25

Expert Comment

by:SStory
ID: 40500695
Great! Glad to help!
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now