?
Solved

Help Speed up function when sorting a listbox

Posted on 2014-03-07
5
Medium Priority
?
259 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 24

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 24

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

How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

Question has a verified solution.

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

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

850 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