Sorting
There are a number of different ways you can sort an array.
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