Solved

Help Speed up function when sorting a listbox

Posted on 2014-03-07
5
241 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 80

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

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Suggested Solutions

Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
Viewers will learn the basics of slicers and timelines for both PivotTables and standard Excel tables in Excel 2013.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

758 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

18 Experts available now in Live!

Get 1:1 Help Now