Solved

Modify Excel VBA Function to Include Sorting

Posted on 2014-12-12
11
300 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 32

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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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 32

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

912 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

19 Experts available now in Live!

Get 1:1 Help Now