我正在为VBA中的数组寻找合适的排序实现。 Quicksort是首选。或者除了泡沫或合并之外的任何其他sort algorithm就足够了。
请注意，这是为了与MS Project 2003一起使用，因此应避免使用任何Excel本机函数和任何.net相关的函数。
看看here： 编辑：引用的源（allexperts.com）已关闭，但这里是相关的author评论：
网上有许多可用于排序的算法。最通用，通常最快的是Quicksort algorithm。以下是它的功能。
简单地通过传递一个值数组（字符串或数字;无关紧要）和下部数组边界（通常是
0）和上部数组边界（即UBound(myArray)）来调用它。示例：
Call QuickSort(myArray, 0, UBound(myArray))完成后，
myArray将被排序，您可以用它做你想做的事。 （来源：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
请注意，这仅适用于一维（又名“普通”？）数组。 （有一个工作的多维数组QuickSort here。）
这就是我用来在内存中排序的东西 - 它可以很容易地扩展为对数组进行排序。
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
如果其他人想要的话，我将'快速快速排序'算法转换为VBA。
我已将其优化为在Int / Longs数组上运行，但将其转换为适用于任意可比元素的数组应该很简单。
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
Explanation德语，但代码是经过充分测试的就地实现：
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
像这样调用：
Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))
我发布了一些代码来回答StackOverflow上的相关问题：
Sorting a multidimensionnal array in VBA
该线程中的代码示例包括：
Alain的优化Quicksort非常闪亮：我只是进行了基本的拆分和递归，但上面的代码示例具有“门控”功能，可以减少重复值的冗余比较。另一方面，我为Excel编写代码，并且在防御性编码方面还有一些 - 请注意，如果你的数组包含有害的'Empty（）'变体，你将需要它，这会破坏你的.. 。比较运算符并将代码陷入无限循环。
请注意，快速排序算法 - 以及任何递归算法 - 都可以填充堆栈并使Excel崩溃。如果您的阵列少于1024个成员，我将使用基本的冒泡排序。
Public Sub QuickSortArray(ByRef SortArray As Variant, _
Optional lngMin As Long = -1, _
Optional lngMax As Long = -1, _
Optional lngColumn As Long = 0)
On Error Resume Next
'Sort a 2-Dimensional array
' Sample Usage: sort arrData by the contents of column 3
'
' QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid might pick up a valid default member or 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
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub
自然数（字符串）快速排序
只是为了填写主题。通常，如果您使用数字对字符串进行排序，您将获得以下内容：
Text1
Text10
Text100
Text11
Text2
Text20
但是你真的希望它能够识别数值并进行排序
Text1
Text2
Text10
Text11
Text20
Text100
这是怎么做的......
注意：
自然数快速排序
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
自然数比较（用于快速排序）
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（用于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
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
您不想要基于Excel的解决方案，但由于我今天遇到了同样的问题，并且想要使用其他Office应用程序功能进行测试，我编写了下面的函数。
限制：
测试从Visio 2010调用Excel 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
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
如果有人使用其他版本的办公室对此进行测试，请在此处发布，如果有任何问题。
我想知道你对这个数组排序代码有什么看法。它很快就可以实现并完成工作......还没有测试过大型阵列。它适用于一维数组，对于多维附加值，需要构建重定位矩阵（初始数组的维数少一个）。
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
我认为我的代码（经过测试）更“受过教育”，假设越简单越好。
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