Help Speed up function when sorting a listbox

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

LVL 3
FordraidersAsked:
Who is Participating?
 
byundtConnect With a Mentor Commented:
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
 
Ejgil HedegaardCommented:
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
 
FordraidersAuthor Commented:
I have tried that in the past...I need to be able to do this in an array sort for function code please.
0
 
Ejgil HedegaardCommented:
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
 
FordraidersAuthor Commented:
Thanks very much
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.