VBA array sort function?

Question

I am looking for a decent sorting implementation for arrays in VBA. Quick sorting would be preferable. Or any sorting algorithm other than a bubble or merge will suffice.

Please note that this is for working with MS Project 2003, so you should avoid any native Excel functions and anything related to .net.

Answer 1

Take a look here :
Edit: The link source (allexperts.com) has since been closed, but here are the relevant comments from the author :

There are many sorting algorithms available on the Internet. The most versatile and usually the fastest is the quicksort algorithm . Below is the function for this.

Call it simply by passing an array of values ​​(string or numeric; it doesn't matter) with the lower bound of the array (usually 0 ) and the upper UBound(myArray) array (i.e. UBound(myArray) .)

Example : Call QuickSort(myArray, 0, UBound(myArray))

When this is done, myArray will be sorted, and you can do whatever you want with it.
_{(Source: archive.org )}

 Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long) Dim pivot As Variant Dim tmpSwap As Variant Dim tmpLow As Long Dim tmpHi As Long tmpLow = inLow tmpHi = inHi pivot = vArray((inLow + inHi) \ 2) While (tmpLow <= tmpHi) While (vArray(tmpLow) < pivot And tmpLow < inHi) tmpLow = tmpLow + 1 Wend While (pivot < vArray(tmpHi) And tmpHi > inLow) tmpHi = tmpHi - 1 Wend If (tmpLow <= tmpHi) Then tmpSwap = vArray(tmpLow) vArray(tmpLow) = vArray(tmpHi) vArray(tmpHi) = tmpSwap tmpLow = tmpLow + 1 tmpHi = tmpHi - 1 End If Wend If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi End Sub 

Note that this only works with one-dimensional (otherwise called "normal"?) Arrays. (There's a working multidimensional QuickSort array here .)

Answer 2

I converted the quick quicksort algorithm to VBA if anyone else wants it.

I optimized it to work in an Int / Longs array, but you just need to convert it to one that works with arbitrary comparable elements.

 Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long) Dim M As Long, i As Long, j As Long, v As Long M = 4 If ((r - l) > M) Then i = (r + l) / 2 If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!' If (a(l) > a(r)) Then swap a, l, r If (a(i) > a(r)) Then swap a, i, r j = r - 1 swap a, i, j i = l v = a(j) Do Do: i = i + 1: Loop While (a(i) < v) Do: j = j - 1: Loop While (a(j) > v) If (j < i) Then Exit Do swap a, i, j Loop swap a, i, r - 1 QuickSort a, l, j QuickSort a, i + 1, r End If End Sub Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long) Dim T As Long T = a(i) a(i) = a(j) a(j) = T End Sub Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long) Dim i As Long, j As Long, v As Long For i = lo0 + 1 To hi0 v = a(i) j = i Do While j > lo0 If Not a(j - 1) > v Then Exit Do a(j) = a(j - 1) j = j - 1 Loop a(j) = v Next i End Sub Public Sub sort(ByRef a() As Long) QuickSort a, LBound(a), UBound(a) InsertionSort a, LBound(a), UBound(a) End Sub 

Answer 3

The explanation is in German, but the code is a field-tested implementation:

 Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long) Dim P1 As Long, P2 As Long, Ref As String, TEMP As String P1 = LB P2 = UB Ref = Field((P1 + P2) / 2) Do Do While (Field(P1) < Ref) P1 = P1 + 1 Loop Do While (Field(P2) > Ref) P2 = P2 - 1 Loop If P1 <= P2 Then TEMP = Field(P1) Field(P1) = Field(P2) Field(P2) = TEMP P1 = P1 + 1 P2 = P2 - 1 End If Loop Until (P1 > P2) If LB < P2 Then Call QuickSort(Field, LB, P2) If P1 < UB Then Call QuickSort(Field, P1, UB) End Sub 

Called as follows:

 Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray)) 

Answer 4

I posted some code in response to a related question in StackOverflow:

Sorting a multidimensional array in VBA

Code samples in this thread include:

• Array of Quicksort vector arrays;
• Multi-column array QuickSort;
• A BubbleSort.

Optimized Optimization QuickSort is optimized: I just did the basic split recursion, but the code example above has a "gating" function that reduces redundant comparisons of duplicate values. On the other hand, I am coding for Excel, and there is a bit more than protective coding - be careful, you will need it if your array contains a harmful version of Empty () that will break your time. Wend comparing operators and grab your code in an endless loop.

Note that quicksort algorthms algorithms - and any recursive algorithm - can populate the stack and crash Excel. If your array has less than 1024 members, I would use a rudimentary BubbleSort.

 Open Sub QuickSortArray (ByRef SortArray As Variant, _ Optional lngMin As Long = -1, _ Optional lngMax As Long = -1, _ Optional lngColumn As Long = 0)
 On error Continue on 

  = lngMax Then no sorting of Exit Sub is required
 End if 


 "We send" Empty "and invalid data elements to the end of the list:
 If IsObject (varMid), then "note that we do not check isObject (SortArray (n)) - varMid can select a valid element or default property i = lngMax j ​​= lngMin
 ElseIf IsEmpty (varMid) Then i = lngMax j ​​= lngMin
 ElseIf IsNull (varMid) Then i = lngMax j ​​= lngMin
 ElseIf varMid = "" Then i = lngMax j ​​= lngMin
 ElseIf varType (varMid) = vbError Then i = lngMax j ​​= lngMin
 ElseIf varType (varMid)> 17 Then i = lngMax j ​​= lngMin
 End if 

  lngMin j = j - 1 Wend 


 Wend 

 End sub 

Answer 5

Natural Number (Strings) Quick Sort

Just buy a theme. Usually, if you sort strings with numbers, you will get something like this:

  Text1 Text10 Text100 Text11 Text2 Text20 

But you really want it to recognize numerical values ​​and sort as

  Text1 Text2 Text10 Text11 Text20 Text100 

Here's how to do it ...

The note:

• I stole Quick Sort from the Internet a long time ago, not sure where now ...
• I translated the CompareNaturalNum function, which was originally written in C from the Internet.
• Unlike other Q-Sorts: I do not change the value if BottomTemp = TopTemp

Natural number Quick sort

 Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer) Dim strPivot As String, strTemp As String Dim intBottomTemp As Integer, intTopTemp As Integer intBottomTemp = intBottom intTopTemp = intTop strPivot = strArray((intBottom + intTop) \ 2) Do While (intBottomTemp <= intTopTemp) ' < comparison of the values is a descending sort Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop) intBottomTemp = intBottomTemp + 1 Loop Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) ' intTopTemp = intTopTemp - 1 Loop If intBottomTemp < intTopTemp Then strTemp = strArray(intBottomTemp) strArray(intBottomTemp) = strArray(intTopTemp) strArray(intTopTemp) = strTemp End If If intBottomTemp <= intTopTemp Then intBottomTemp = intBottomTemp + 1 intTopTemp = intTopTemp - 1 End If Loop 'the function calls itself until everything is in good order If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop End Sub 

Comparison of natural numbers (used in quick sorting)

 Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer 'string1 is less than string2 -1 'string1 is equal to string2 0 'string1 is greater than string2 1 Dim n1 As Long, n2 As Long Dim iPosOrig1 As Integer, iPosOrig2 As Integer Dim iPos1 As Integer, iPos2 As Integer Dim nOffset1 As Integer, nOffset2 As Integer If Not (IsNull(string1) Or IsNull(string2)) Then iPos1 = 1 iPos2 = 1 Do While iPos1 <= Len(string1) If iPos2 > Len(string2) Then CompareNaturalNum = 1 Exit Function End If If isDigit(string1, iPos1) Then If Not isDigit(string2, iPos2) Then CompareNaturalNum = -1 Exit Function End If iPosOrig1 = iPos1 iPosOrig2 = iPos2 Do While isDigit(string1, iPos1) iPos1 = iPos1 + 1 Loop Do While isDigit(string2, iPos2) iPos2 = iPos2 + 1 Loop nOffset1 = (iPos1 - iPosOrig1) nOffset2 = (iPos2 - iPosOrig2) n1 = Val(Mid(string1, iPosOrig1, nOffset1)) n2 = Val(Mid(string2, iPosOrig2, nOffset2)) If (n1 < n2) Then CompareNaturalNum = -1 Exit Function ElseIf (n1 > n2) Then CompareNaturalNum = 1 Exit Function End If ' front padded zeros (put 01 before 1) If (n1 = n2) Then If (nOffset1 > nOffset2) Then CompareNaturalNum = -1 Exit Function ElseIf (nOffset1 < nOffset2) Then CompareNaturalNum = 1 Exit Function End If End If ElseIf isDigit(string2, iPos2) Then CompareNaturalNum = 1 Exit Function Else If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then CompareNaturalNum = -1 Exit Function ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then CompareNaturalNum = 1 Exit Function End If iPos1 = iPos1 + 1 iPos2 = iPos2 + 1 End If Loop ' Everything was the same so far, check if Len(string2) > Len(String1) ' If so, then string1 < string2 If Len(string2) > Len(string1) Then CompareNaturalNum = -1 Exit Function End If Else If IsNull(string1) And Not IsNull(string2) Then CompareNaturalNum = -1 Exit Function ElseIf IsNull(string1) And IsNull(string2) Then CompareNaturalNum = 0 Exit Function ElseIf Not IsNull(string1) And IsNull(string2) Then CompareNaturalNum = 1 Exit Function End If End If End Function 

isDigit (used in CompareNaturalNum)

 Function isDigit(ByVal str As String, pos As Integer) As Boolean Dim iCode As Integer If pos <= Len(str) Then iCode = Asc(Mid(str, pos, 1)) If iCode >= 48 And iCode <= 57 Then isDigit = True End If End Function 

Answer 6

 Dim arr As Object Dim InputArray 'Creating a array list Set arr = CreateObject("System.Collections.ArrayList") 'String InputArray = Array("d", "c", "b", "a", "f", "e", "g") 'number 'InputArray = Array(6, 5, 3, 4, 2, 1) ' adding the elements in the array to array_list For Each element In InputArray arr.Add element Next 'sorting happens arr.Sort 'Converting ArrayList to an array 'so now a sorted array of elements is stored in the array sorted_array. sorted_array = arr.toarray 

Answer 7

You didn't want an Excel-based solution, but since I had the same problem today and wanted to test using other Office Applications features, I wrote a function below.

Limitations:

• 2-dimensional arrays;
• maximum 3 columns as sort keys;
• depends on Excel;

Tested calling Excel 2010 from Visio 2010

---

 Option Base 1 Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False") ' Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library Dim excel_application As Excel.Application Dim excel_workbook As Excel.Workbook Dim excel_worksheet As Excel.Worksheet Set excel_application = CreateObject("Excel.Application") excel_application.Visible = True excel_application.ScreenUpdating = False excel_application.WindowState = xlNormal Set excel_workbook = excel_application.Workbooks.Add excel_workbook.Activate Set excel_worksheet = excel_workbook.Worksheets.Add excel_worksheet.Activate excel_worksheet.Visible = xlSheetVisible Dim excel_range As Excel.Range Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1) excel_range = array_2D For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys) If IsNumeric(array_sortkeys(i_sortkey)) Then sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1" Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range) Else MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..." End End If Next i_sortkey For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders) Select Case LCase(array_sortorders(i_sortorder)) Case "asc" array_sortorders(i_sortorder) = XlSortOrder.xlAscending Case "desc" array_sortorders(i_sortorder) = XlSortOrder.xlDescending Case Else array_sortorders(i_sortorder) = XlSortOrder.xlAscending End Select Next i_sortorder Select Case LCase(tag_header) Case "yes" tag_header = Excel.xlYes Case "no" tag_header = Excel.xlNo Case "guess" tag_header = Excel.xlGuess Case Else tag_header = Excel.xlGuess End Select Select Case LCase(tag_matchcase) Case "true" tag_matchcase = True Case "false" tag_matchcase = False Case Else tag_matchcase = False End Select Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1) Case 1 Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase) Case 2 Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase) Case 3 Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase) Case Else MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1) End End Select For i_row = 1 To excel_range.Rows.Count For i_column = 1 To excel_range.Columns.Count array_2D(i_row, i_column) = excel_range(i_row, i_column) Next i_column Next i_row excel_workbook.Close False excel_application.Quit Set excel_worksheet = Nothing Set excel_workbook = Nothing Set excel_application = Nothing sort_array_2D_excel = array_2D End Function 

---

This is an example of how to test a function:

 Private Sub test_sort() array_unsorted = dim_sort_array() Call msgbox_array(array_unsorted) array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False") Call msgbox_array(array_sorted) End Sub Private Function dim_sort_array() Dim array_unsorted(1 To 5, 1 To 3) As String i_row = 0 i_row = i_row + 1 array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3" i_row = i_row + 1 array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2) i_row = i_row + 1 array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2) i_row = i_row + 1 array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2) i_row = i_row + 1 array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2) dim_sort_array = array_unsorted End Function Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:") msgbox_string = string_info & vbLf For i_row = LBound(array_2D, 1) To UBound(array_2D, 1) msgbox_string = msgbox_string & vbLf & i_row & vbTab For i_column = LBound(array_2D, 2) To UBound(array_2D, 2) msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab Next i_column Next i_row MsgBox msgbox_string End Sub 

---

If someone checks this using other versions of the office, please write here if there is any problem.

Answer 8

Interestingly, what would you say about this array sorting method. This is fast to implement, and this work ... has not yet been tested for large arrays. It works for one-dimensional arrays, since a multi-dimensional additional value redefinition matrix must be constructed (with one smaller size than the original array).

  For AR1 = LBound(eArray, 1) To UBound(eArray, 1) eValue = eArray(AR1) For AR2 = LBound(eArray, 1) To UBound(eArray, 1) If eArray(AR2) < eValue Then eArray(AR1) = eArray(AR2) eArray(AR2) = eValue eValue = eArray(AR1) End If Next AR2 Next AR1 

Answer 9

This is what I use for sorting in memory - it can easily be expanded to sort the array.

 Sub sortlist() Dim xarr As Variant Dim yarr As Variant Dim zarr As Variant xarr = Sheets("sheet").Range("sing col range") ReDim yarr(1 To UBound(xarr), 1 To 1) ReDim zarr(1 To UBound(xarr), 1 To 1) For n = 1 To UBound(xarr) zarr(n, 1) = 1 Next n For n = 1 To UBound(xarr) - 1 y = zarr(n, 1) For a = n + 1 To UBound(xarr) If xarr(n, 1) > xarr(a, 1) Then y = y + 1 Else zarr(a, 1) = zarr(a, 1) + 1 End If Next a yarr(y, 1) = xarr(n, 1) Next n y = zarr(UBound(xarr), 1) yarr(y, 1) = xarr(UBound(xarr), 1) yrng = "A1:A" & UBound(yarr) Sheets("sheet").Range(yrng) = yarr End Sub 

Answer 10

I think my code (verified) is more "educated", assuming that the simpler the better.

 Option Base 1 'Function to sort an array decscending Function SORT(Rango As Range) As Variant Dim check As Boolean check = True If IsNull(Rango) Then check = False End If If check Then Application.Volatile Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m ReDim x(n, m) For i = 1 To n Step 1 For j = 1 To m Step 1 x(i, j) = Application.Large(Rango, k) k = k - 1 Next j Next i SORT = x Else Exit Function End If End Function 

Answer 11

Heapsort implementation. O (n log (n)) (both average and worst case), an unstable sorting algorithm.

Use with: Call HeapSort(A) , where A is a one-dimensional array of options, with Option Base 1 .

 Sub SiftUp(A() As Variant, I As Long) Dim K As Long, P As Long, S As Variant K = I While K > 1 P = K \ 2 If A(K) > A(P) Then S = A(P): A(P) = A(K): A(K) = S K = P Else Exit Sub End If Wend End Sub Sub SiftDown(A() As Variant, I As Long) Dim K As Long, L As Long, S As Variant K = 1 Do L = K + K If L > I Then Exit Sub If L + 1 <= I Then If A(L + 1) > A(L) Then L = L + 1 End If If A(K) < A(L) Then S = A(K): A(K) = A(L): A(L) = S K = L Else Exit Sub End If Loop End Sub Sub HeapSort(A() As Variant) Dim N As Long, I As Long, S As Variant N = UBound(A) For I = 2 To N Call SiftUp(A, I) Next I For I = N To 2 Step -1 S = A(I): A(I) = A(1): A(1) = S Call SiftDown(A, I - 1) Next End Sub