Gregory Silvano has these tips for speeding up bubblesort in his application.

When I find a URL I do a binary search through an array of existing URLs. If it's not in the list I add it to the *bottom* of the array and resort the array. The performance boost is that the bubble sort bubbles *up* once and quits as soon as it places the item. That involves three modifications - move in only one direction; only make one pass; and quit as soon as the item is placed (it normally continues up the array). I think that's the whole concept - I wrote it two years ago so I may have left out something.

I don't redim the array every time - I add blank items in blocks of 500. The "max" parameter is the number of items in the array, since I can't use Ubound().

The second idea of redimming the array in chunks is useful for any algorithm that needs to resize an array a lot. Here's Gregory's code:

Public Type url
    'other properties deleted
    CompareHREF As String 'an lcase() version of the real
        ' href
End Type

Private Sub SortURLs(arURLs() As url, ByVal min As Long, _
    ByVal max As Long)
Dim bAllDone As Boolean
Dim last_swap As Long
Dim i As Long
Dim j As Long
Dim tmp As url

    Do While min < max
        ' Bubble up. The new item is at the bottom of the
        ' array
        last_swap = max + 1
        ' For i = max - 1 To min Step -1
        i = max - 1
        Do While i >= min
            ' Find a bubble.
            If arURLs(i + 1).CompareHREF < _
                arURLs(i).CompareHREF Then
                ' See where to drop the bubble.
                tmp = arURLs(i + 1)
                j = i
                Do
                    arURLs(j + 1) = arURLs(j)
                    j = j - 1
                    If j < min Then
                        bAllDone = True
                        Exit Do
                    End If
                Loop While arURLs(j).CompareHREF > _
                    tmp.CompareHREF
                arURLs(j + 1) = tmp
                last_swap = j + 1
                i = j - 1
            Else
                i = i - 1
            End If
            If bAllDone Then GoTo ExitSort
        Loop
        ' Update min.
        min = last_swap + 1
    Loop
    
ExitSort:

End Sub