Solved

Help Speed up function when sorting a listbox

Posted on 2014-03-07
5
244 Views
Last Modified: 2014-03-10
excel 2010 vba.

Passing parameters to this function:

Call blnSort_List_Box(UserForm2.ListBox32, 3, True, True, FName)

Example: FName = "AMAZON SUPPLY"
If FName exists in the listbox that row gets bumped to the top of the list



Problem..
Filling a listbox then soting via these parameters.
sometimes the listbox contains 800 items.
THis code is talking 13-20 sec to sort.

Just looking to see if there is a way to make i run faster.



Public Function blnSort_List_Box(ByRef objListbox As Control, _
                                  ByVal lngSort_Column As Long, _
                                  ByVal blnSort_Alphanumeric As Boolean, _
                                  ByVal blnSort_Ascending As Boolean, _
                                  Optional ByVal vntPriority_Value As Variant) As Boolean

  Dim blnReturn                                         As Boolean
  Dim lngColumn                                         As Long
  Dim lngErr_Number                                     As Long
  Dim lngRow                                            As Long
  Dim lngRow1                                           As Long
  Dim strErr_Description                                As String
  Dim strPriority_Value                                 As String
  Dim vntList                                           As Variant
  Dim vntSwap                                           As Variant
    
  On Error GoTo Err_blnSort_List_Box
  
  blnReturn = False

  vntList = objListbox.List
  If Not IsMissing(vntPriority_Value) Then
     strPriority_Value = UCase$(vntPriority_Value)                                                                                                      ' *** NL [18/12/2013]: Changed from CStr(...) to UCase$(...)
     For lngRow = LBound(vntList, 1&) To (UBound(vntList, 1&) - 1&)
         If Not IsNull(vntList(lngRow, lngSort_Column)) Then
            If InStr(UCase$(vntList(lngRow, lngSort_Column)), strPriority_Value) > 0 Then                                                               ' *** NL [18/12/2013]: Added
               vntList(lngRow, lngSort_Column) = Chr$(1) & CStr(vntList(lngRow, lngSort_Column))
            End If                                                ' *** NL [18/12/2013]: Added
         End If
         
     Next lngRow
  End If
  
  If (blnSort_Alphanumeric) Then
     For lngRow = LBound(vntList, 1&) To (UBound(vntList, 1&) - 1&)
         For lngRow1 = (lngRow + 1&) To UBound(vntList, 1&)
             If (blnSort_Ascending) Then
                If IIf(Len(Trim$(IIf(IsNull(vntList(lngRow, lngSort_Column)), "", vntList(lngRow, lngSort_Column)))) = 0, String$(255, Chr$(255)), vntList(lngRow, lngSort_Column)) > _
                   IIf(Len(Trim$(IIf(IsNull(vntList(lngRow1, lngSort_Column)), "", vntList(lngRow1, lngSort_Column)))) = 0, String$(255, Chr$(255)), vntList(lngRow1, lngSort_Column)) Then
                   For lngColumn = 0& To (objListbox.ColumnCount - 1&)
                       vntSwap = vntList(lngRow, lngColumn)
                       vntList(lngRow, lngColumn) = vntList(lngRow1, lngColumn)
                       vntList(lngRow1, lngColumn) = vntSwap
                   Next lngColumn
                End If
             Else
                If vntList(lngRow, lngSort_Column) < vntList(lngRow1, lngSort_Column) Then
                   For lngColumn = 0& To (objListbox.ColumnCount - 1&)
                       vntSwap = vntList(lngRow, lngColumn)
                       vntList(lngRow, lngColumn) = vntList(lngRow1, lngColumn)
                       vntList(lngRow1, lngColumn) = vntSwap
                   Next lngColumn
                End If
             End If
    
         Next lngRow1
         
     Next lngRow
  Else
' Note: Substitute CInt() with another conversion type [CLng(), CDec(), etc.] depending on the column's numeric values.
'       Also, change the value 32767 (Integer) to the maximum value the revised data type can store.
     For lngRow = LBound(vntList, 1&) To (UBound(vntList, 1&) - 1&)
         For lngRow1 = (lngRow + 1&) To UBound(vntList, 1&)
             If (blnSort_Ascending) Then
                If CInt(IIf(Len(Trim$(IIf(IsNull(vntList(lngRow, lngSort_Column)), "", vntList(lngRow, lngSort_Column)))) = 0, 32767, vntList(lngRow, lngSort_Column))) > _
                   CInt(IIf(Len(Trim$(IIf(IsNull(vntList(lngRow1, lngSort_Column)), "", vntList(lngRow1, lngSort_Column)))) = 0, 32767, vntList(lngRow1, lngSort_Column))) Then
                   For lngColumn = 0& To (objListbox.ColumnCount - 1&)
                        vntSwap = IIf(Len(Trim$(IIf(IsNull(vntList(lngRow, lngColumn)), "", vntList(lngRow, lngColumn)))) = 0, "", vntList(lngRow, lngColumn))
                        vntList(lngRow, lngColumn) = IIf(Len(Trim$(IIf(IsNull(vntList(lngRow1, lngColumn)), "", vntList(lngRow1, lngColumn)))) = 0, "", vntList(lngRow1, lngColumn))
                        vntList(lngRow1, lngColumn) = vntSwap
                   Next lngColumn
                End If
             Else
                If CInt(IIf(Len(Trim$(IIf(IsNull(vntList(lngRow, lngSort_Column)), "", vntList(lngRow, lngSort_Column)))) = 0, "0", vntList(lngRow, lngSort_Column))) < _
                   CInt(IIf(Len(Trim$(IIf(IsNull(vntList(lngRow1, lngSort_Column)), "", vntList(lngRow1, lngSort_Column)))) = 0, "0", vntList(lngRow1, lngSort_Column))) Then
                   For lngColumn = 0& To (objListbox.ColumnCount - 1&)
                       vntSwap = IIf(Len(Trim$(IIf(IsNull(vntList(lngRow, lngColumn)), "", vntList(lngRow, lngColumn)))) = 0, "", vntList(lngRow, lngColumn))
                       vntList(lngRow, lngColumn) = IIf(Len(Trim$(IIf(IsNull(vntList(lngRow1, lngColumn)), "", vntList(lngRow1, lngColumn)))) = 0, "", vntList(lngRow1, lngColumn))
                       vntList(lngRow1, lngColumn) = vntSwap
                   Next lngColumn
                End If
             End If
    
         Next lngRow1
         
     Next lngRow
  End If
  
  If Not IsMissing(vntPriority_Value) Then
     For lngRow = LBound(vntList, 1&) To (UBound(vntList, 1&) - 1&)
         
         If Not (IsNull(vntList(lngRow, lngSort_Column))) Then
            If Len(Trim$(vntList(lngRow, lngSort_Column))) > 0 Then
               If Asc(vntList(lngRow, lngSort_Column)) = 1 Then
                  vntList(lngRow, lngSort_Column) = Mid$(vntList(lngRow, lngSort_Column), 2)
               End If
            End If
         End If
         
     Next lngRow
  End If
    
  objListbox.List = vntList
    
  blnReturn = True

Open in new window

0
Comment
Question by:fordraiders
  • 2
  • 2
5 Comments
 
LVL 21

Expert Comment

by:Ejgil Hedegaard
ID: 39914678
Save the array with the list to a worksheet, sort, and read the values back to the listbox.
It will take "no time" to sort 800 values on a worksheet.
The sheet can be hidden, but has to be activated to perform the sorting operation.
0
 
LVL 3

Author Comment

by:fordraiders
ID: 39915289
I have tried that in the past...I need to be able to do this in an array sort for function code please.
0
 
LVL 21

Expert Comment

by:Ejgil Hedegaard
ID: 39916179
I searched for a VBA sorting method some years back, but no matter what I found, it was slow (very slow) compared to put the array on a worksheet, sort and read the array again. So I always do that.
Sorry, can't help with a VBA solution.
0
 
LVL 81

Accepted Solution

by:
byundt earned 500 total points
ID: 39916538
John Walkenbach discussed the results of a study he performed on sorting data in VBA in his book Excel 2002 Power Programming With VBA. I'd guess that other versions of that same book include the same discussion.

Walkenbach was able to consistently beat the speed of the worksheet sort using a so-called counting sort: 0.11 seconds for 1000 random elements using Excel worksheet sort and 0.00 seconds using a counting sort.

If you don't have the CD that accompanies Walkenbach's book (that's where the code is posted), then you may find a version of the counting sort for multi-dimensional arrays to be useful. There is a forum question discussing that issue in VBA Express "Counting sort for multi-dimensional arrays" http://www.vbaexpress.com/forum/showthread.php?3255-Solved-Counting-sort-for-multi-dimensional-arrays  That thread includes code for both sorting a single column as well as sorting by one column while retaining results in other columns of that array.
0
 
LVL 3

Author Closing Comment

by:fordraiders
ID: 39919711
Thanks very much
0

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

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

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
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 use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

825 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