Sorting
There are a number of different ways you can sort an array.
When comparing string values you need to be aware of Option Compare
Excel Sort
Excel Sort is definitely the fastest.
This transfers the array to a worksheet, sorts the array and then transfers it back to the array.
Public Sub TestSort()
Dim avTesting() As Variant
avTesting = Array(45, 30, 25, 15, 10, 5, 40, 20, 35, 50)
Call Array_ExcelSort(avTesting)
Stop
End Sub
Public Sub Array_ExcelSort(ByRef vArrayName As Variant)
Dim vReturnArray As Variant
Dim lLower As Integer
Dim lUpper As Long
Dim i As Long
Dim FirstCell As Excel.Range
Dim LastCell As Excel.Range
Dim CurrCell As Excel.Range
Dim FillRange As Excel.Range
lLower = LBound(vArrayName, 1)
lUpper = UBound(vArrayName, 1)
Set FirstCell = Sheets("Sheet1").Cells(1, 1)
Set LastCell = Sheets("Sheet1").Cells(lUpper + 1, 1)
Set FillRange = Range(FirstCell, LastCell)
'Application.ScreenUpdating = False
ReDim vReturnArray(lLower To lUpper)
vArrayName = Application.WorksheetFunction.Transpose(vArrayName)
FillRange.Value = vArrayName
FirstCell.CurrentRegion.Sort Key1:=FirstCell, Order1:=xlAscending, Orientation:=xlTopToBottom
For i = lLower To lUpper
vReturnArray(i) = FirstCell.Offset(i, 0)
Next i
FillRange.Clear
'Application.ScreenUpdating = True
vArrayName = vReturnArray
End Sub
Bubble Sort
Bubble Sort uses a 'swapping' strategy to repeatedly swap the adjacent elements if they are in wrong order.
The Bubble sort is reasonably fast with small arrays but for larger arrays (> 5,000) forget it !!
Public Sub TestSort()
Dim avTesting() As Variant
avTesting = Array(2, 2, 1, 2, 2)
Call Array_BubbleSort(avTesting)
avTesting = Array(45, 30, 25, 15, 10, 5, 40, 20, 35, 50)
Call Array_BubbleSort(avTesting)
avTesting = Array(50, 45, 40, 35, 30, 25, 20, 15, 10, 5)
Call Array_BubbleSort(avTesting)
Stop
End Sub
Public Sub Array_BubbleSort(ByRef vArrayName As Variant, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal lLower As Long = -1)
Dim vArrayResult1 As Variant
Dim vArrayResult2 As Variant
Dim vArrayResult3 As Variant
Dim vtemp As Variant
Dim bAllSwapped As Boolean
Dim inoofswaps As Integer
Dim inoofloops As Integer
Dim i As Long
Dim j As Long
If IsEmpty(vArrayName) = True Then Exit Sub
If lLower = -1 Then lLower = LBound(vArrayName, 1)
If lUpper = -1 Then lUpper = UBound(vArrayName, 1)
'Algorithm 1
vArrayResult1 = vArrayName
inoofswaps = 0
inoofloops = 0
For i = lLower To (lUpper - 1)
For j = (i + 1) To lUpper
If (vArrayResult1(j) < vArrayResult1(i)) Then
vtemp = vArrayResult1(i)
vArrayResult1(i) = vArrayResult1(j)
vArrayResult1(j) = vtemp
inoofswaps = inoofswaps + 1
End If
inoofloops = inoofloops + 1
Next j
Next i
Debug.Print "Algorithm 1 - swaps:" & inoofswaps & " loops:" & inoofloops
'Algorithm 2
vArrayResult2 = vArrayName
inoofswaps = 0
inoofloops = 0
For i = lLower To (lUpper - 1)
For j = lLower To (lUpper - 1)
If (vArrayResult2(j) > vArrayResult2(j + 1)) Then
vtemp = vArrayResult2(j)
vArrayResult2(j) = vArrayResult2(j + 1)
vArrayResult2(j + 1) = vtemp
inoofswaps = inoofswaps + 1
End If
inoofloops = inoofloops + 1
Next j
Next i
Debug.Print "Algorithm 2 - swaps:" & inoofswaps & " loops:" & inoofloops
'Algorithm 3
vArrayResult3 = vArrayName
inoofswaps = 0
inoofloops = 0
Do
bAllSwapped = False
For j = lLower To (lUpper - 1)
If (vArrayResult3(j) > vArrayResult3(j + 1)) Then
vtemp = vArrayResult3(j)
vArrayResult3(j) = vArrayResult3(j + 1)
vArrayResult3(j + 1) = vtemp
bAllSwapped = True
inoofswaps = inoofswaps + 1
End If
inoofloops = inoofloops + 1
Next j
lUpper = lUpper - 1
Loop Until bAllSwapped = False
Debug.Print "Algorithm 3 - swaps:" & inoofswaps & " loops:" & inoofloops
'vArrayName = vArrayResult1
'vArrayName = vArrayResult2
vArrayName = vArrayResult3
End Sub
Counting Sort
Counting Sort uses a 'counting' strategy to count the number of occurrences of each unique element in the array.
Public Sub TestSort()
Dim avTesting() As Variant
avTesting = Array(45, 30, 25, 15, 10, 5, 40, 20, 35, 50)
Call Array_CountingSort(avTesting)
Stop
End Sub
Public Sub Array_CountingSort(ByRef vArrayName As Variant)
Dim vCounting() As Long
Dim lLower As Long
Dim lUpper As Long
Dim larraymin As Long
Dim larraymax As Long
Dim lnextpos As Long
Dim i As Long
Dim j As Long
larraymin = Helper_Minimum(vArrayName)
larraymax = Helper_Maximum(vArrayName)
lLower = LBound(vArrayName)
lUpper = UBound(vArrayName)
ReDim vCounting(larraymin To larraymax)
For i = lLower To lUpper
vCounting(vArrayName(i)) = vCounting(vArrayName(i)) + 1
Next i
lnextpos = lLower
For i = larraymin To larraymax
For j = 1 To vCounting(i)
vArrayName(lnextpos) = i
lnextpos = lnextpos + 1
Next j
Next i
End Sub
Public Function Helper_Maximum(ByVal vArrayName As Variant) As Long
Dim lmaxvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lmaxvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) > lmaxvalue) Then
lmaxvalue = vArrayName(i)
End If
Next i
Helper_Maximum = lmaxvalue
End Function
Public Function Helper_Minimum(ByVal vArrayName As Variant) As Long
Dim lminvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lminvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) < lminvalue) Then
lminvalue = vArrayName(i)
End If
Next i
Helper_Minimum = lminvalue
End Function
Quick Sort
Quick Sort uses a 'divide and conquer' strategy to divide a list into two sub-lists.
The Quick Sort is fast when the array needs a lot of sorting.
If the array is partially sorted this may not be the fastest algorithm.
Public Sub TestSort()
Dim avTesting() As Variant
avTesting = Array(45, 30, 25, 15, 10, 5, 40, 20, 35, 50)
Call Array_QuickSort(avTesting)
Stop
End Sub
Public Sub Array_QuickSort(ByRef vArrayName As Variant, _
Optional ByVal lLower As Long = -1, _
Optional ByVal lUpper As Long = -1)
Dim vmiddlevalue As Variant
Dim lmiddle As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim stemp As String
If IsEmpty(vArrayName) = True Then Exit Sub
If lLower = -1 Then lLower = LBound(vArrayName, 1)
If lUpper = -1 Then lUpper = UBound(vArrayName, 1)
If lLower < lUpper Then
'lmiddle = lLower
lmiddle = (lLower + lUpper) / 2
'lmiddle = VBA.Int(lLower + VBA.Rnd * (lUpper - lLower + 1))
vmiddlevalue = vArrayName(lmiddle)
lrowlower = lLower
lrowupper = lUpper
Do While lrowlower < lrowupper
Do While (vArrayName(lrowupper) >= vmiddlevalue) And (lrowlower < lrowupper)
lrowupper = lrowupper - 1
Loop
If (lrowlower <> lrowupper) Then
stemp = vArrayName(lrowlower)
vArrayName(lrowlower) = vArrayName(lrowupper)
vArrayName(lrowupper) = stemp
lrowlower = lrowlower + 1
End If
Do While (vArrayName(lrowlower) <= vmiddlevalue) And (lrowlower < lrowupper)
lrowlower = lrowlower + 1
Loop
If (lrowlower <> lrowupper) Then
stemp = vArrayName(lrowupper)
vArrayName(lrowupper) = vArrayName(lrowlower)
vArrayName(lrowlower) = stemp
lrowupper = lrowupper - 1
End If
Loop
vArrayName(lrowlower) = vmiddlevalue
lmiddle = lrowlower
lrowlower = lLower
lrowupper = lUpper
If (lrowlower < lmiddle) Then
Call Array_QuickSort(vArrayName, lrowlower, lmiddle - 1)
End If
If (lrowupper > lmiddle) Then
Call Array_QuickSort(vArrayName, lmiddle + 1, lrowupper)
End If
End If
End Sub
Insertion Sort
Public Sub InsertionSort(ByRef arr() As Double)
Dim i As Long
Dim j As Long
For i = 1 To UBound(arr)
j = i
Do While (j > 0)
If (arr(j - 1) > arr(j)) Then
Call Swap_Values(arr, j, j - 1)
j = j - 1
Else
Exit Do
End If
Loop
Next i
End Sub
Private Sub Swap_Values(ByRef arr() As Double, _
ByVal i1 As Long, _
ByVal i2 As Long)
Dim buffer As Double
buffer = arr(i1)
arr(i1) = arr(i2)
arr(i2) = buffer
End Sub
This one is faster.
Public Sub InsertionSort2(ByRef arr() As Double)
Dim buffer As Double
Dim i As Long
Dim j As Long
For i = 1 To UBound(arr)
buffer = arr(i)
j = i - 1
Do Until (j < 0)
If (arr(j) > buffer) Then
arr(j + 1) = arr(j)
j = j - 1
Else
Exit Do
End If
Loop
arr(j + 1) = buffer
Next i
End Sub
Word Sort
You can use the following line to sort an array in Microsoft Word
WordBasic.SortArray (arArrayName)
© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited TopPrevNext