我正在寻找一种在VBA中对数组进行体面排序的实现。最好使用Quicksort。或者,除了冒泡或合并以外的任何其他排序算法都足够。
请注意,这是与MS Project 2003一起使用的,因此应避免使用任何Excel本机功能以及与.net相关的任何内容。
Answers:
在这里看看:
编辑: 引用源(allexperts.com)此后已经关闭,但是这里是相关的作者评论:
网上有很多算法可用于排序。功能最丰富,通常最快的是Quicksort算法。下面是它的功能。
只需通过传递带有下数组边界(通常是
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
请注意,这仅适用于一维(也称为“正常”?)阵列。(有一个工作的多维数组快速排序在这里。)
如果有人需要,我将“快速快速排序”算法转换为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
用德语解释,但代码是经过充分测试的就地实现:
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))
ByVal
进入那里。造成混淆的原因可能是在VB.NET中ByVal
可以在这里工作(尽管无论如何在VB.NET中都可以实现)。
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
System.Collections.ArrayList
位于32位和64位Windows中不同位置的问题。我的32位Excel隐式地尝试在32位Win将其存储的位置中找到它,但是由于我具有64位Win,所以我也遇到了一个问题:/我遇到了错误-2146232576 (80131700)
。
自然数(字符串)快速排序
只是为了讨论这个话题。通常,如果您使用数字对字符串进行排序,则会得到以下内容:
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
我在StackOverflow上发布了一些代码来回答相关问题:
该线程中的代码示例包括:
Alain优化的Quicksort非常出色:我只是做了基本的拆分和递归操作,但是上面的代码示例具有“选通”功能,可以减少重复值的冗余比较。另一方面,我为Excel编写代码,并且防御代码还有更多内容-警告,如果您的数组包含有害的“ Empty()”变体,则您将需要它,这会破坏您的While。温和比较运算符,并将您的代码陷入无限循环。
请注意,快速排序算法-以及任何递归算法-可以填充堆栈并使Excel崩溃。如果您的数组的成员少于1024个,那么我将使用基本的BubbleSort。
Public Sub QuickSortArray(ByRef SortArray As Variant,_ 可选的lngMin只要Long = -1,_ 可选的lngMax只要Long = -1,_ 可选的lngColumn只要Long = 0) On Error Resume Next
'将二维数组排序
'示例用法:按第3列的内容对arrData进行排序 ' 'QuickSortArray arrData 、、、、
'
Nigel Heffernan于 98年10月20日发布的Excel.Programming
''转义失败,没有空变量 ''防御性编码:检查输入
昏暗的我只要 Dim j As Long Dim varMid作为变体 Dim arrRowTemp作为变体 尽可能长的暗淡色彩
如果IsEmpty(SortArray)然后 退出子 万一
如果InStr(TypeName(SortArray),“()”)<1,则'IsArray()有点破损:在类型名称中查找方括号 退出子 万一
如果lngMin = -1那么 lngMin = LBound(SortArray,1) 万一
如果lngMax = -1那么 lngMax = UBound(SortArray,1) 万一
如果lngMin> = lngMax然后'无需排序 退出子 万一
我= lngMin j =最大值
varMid =空 varMid = SortArray((lngMin + lngMax)\ 2,lngColumn)
'我们将'Empty'和无效的数据项发送到列表的末尾: 如果IsObject(varMid)然后'请注意,我们不检查isObject(SortArray(n))-varMid可能会选择有效的默认成员或属性 我= lngMax j = lngMin ElseIf IsEmpty(varMid)然后 我= lngMax j = lngMin ElseIf IsNull(varMid)然后 我= lngMax j = lngMin ElseIf varMid =“”然后 我= lngMax j = lngMin ElseIf varType(varMid)= vbError然后 我= lngMax j = lngMin ElseIf varType(varMid)> 17然后 我= lngMax j = lngMin 如果
i <= j则结束
而SortArray(i,lngColumn)<varMid和i <lngMax 我=我+ 1 温德
而varMid <SortArray(j,lngColumn)和j> lngMin j = j-1 WEND
如果我<= j的接着
'交换行 ReDim arrRowTemp(LBound(SortArray,2)到UBound(SortArray,2)) 对于lngColTemp = LBound(SortArray,2)到UBound(SortArray,2) arrRowTemp(lngColTemp)= SortArray(i,lngColTemp) SortArray(i,lngColTemp)= SortArray(j,lngColTemp) SortArray(j,lngColTemp)= arrRowTemp(lngColTemp) 下一个lngColTemp 删除arrRowTemp
我=我+ 1 j = j-
如果
温德结束
如果(lngMin <j)然后调用QuickSortArray(SortArray,lngMin,j,lngColumn) 如果(i <lngMax)然后调用QuickSortArray(SortArray,i,lngMax,lngColumn)
End Sub
您不想要基于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
如果有人使用其他版本的Office测试此功能,请在此处发布任何问题。
msgbox_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
我认为我的代码(经过测试)更加“受过教育”,假设越简单越好。
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
Double
而不是Long
。其次,它不考虑范围是否有多个区域。排序矩形似乎没有用,当然也不是OP要求的(特别是说没有本机Excel / .Net解决方案)。另外,如果您认为越简单越好,就越“受过教育”,那么使用内置Range.Sort()
函数不是最好的吗?
这就是我在内存中排序的方式-可以轻松地扩展它以对数组进行排序。
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
堆排序实现。O(n log(n))(平均情况和最坏情况)就地是不稳定排序算法。
与:一起使用Call HeapSort(A)
,其中的A
是一维变体数组,与一起使用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
@Prasand Kumar,这是一个基于Prasand概念的完整排序例程:
Public Sub ArrayListSort(ByRef SortArray As Variant)
'
'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
'data-type.
'
'AUTHOR: Peter Straton
'
'CREDIT: Derived from Prasand Kumar's post at: /programming/152319/vba-array-sort-function
'
'*************************************************************************************************************
Static ArrayListObj As Object
Dim i As Long
Dim LBnd As Long
Dim UBnd As Long
LBnd = LBound(SortArray)
UBnd = UBound(SortArray)
'If necessary, create the ArrayList object, to be used to sort the specified array's values
If ArrayListObj Is Nothing Then
Set ArrayListObj = CreateObject("System.Collections.ArrayList")
Else
ArrayListObj.Clear 'Already allocated so just clear any old contents
End If
'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
'using a single assignment statement.)
For i = LBnd To UBnd
ArrayListObj.Add SortArray(i)
Next i
ArrayListObj.Sort 'Do the sort
'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
'statement. But the result is always zero-based so then, if necessary, adjust the resulting array to match
'its original index base.
SortArray = ArrayListObj.ToArray
If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub
有点相关,但由于高级数据结构(字典等)在我的环境中不起作用,因此我也在寻找本机excel VBA解决方案。以下是通过VBA中的二叉树实现排序的方法:
"0|2|3|4|9"
可拆分的字符串()。我用它来返回为任意选择范围选择的行的原始排序枚举
Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
If CenterType = tEMPTY Then
Center = x
CenterType = tValue
ElseIf x > Center Then
If RightType = tEMPTY Then
Right = x
RightType = tValue
ElseIf RightType = tTree Then
Right.Add x
ElseIf x <> Right Then
curLeaf = Right
Set Right = New TreeList
Right.Add curLeaf
Right.Add x
RightType = tTree
End If
ElseIf x < Center Then
If LeftType = tEMPTY Then
Left = x
LeftType = tValue
ElseIf LeftType = tTree Then
Left.Add x
ElseIf x <> Left Then
curLeaf = Left
Set Left = New TreeList
Left.Add curLeaf
Left.Add x
LeftType = tTree
End If
End If
End Sub
Public Function GetList$()
Const sep$ = "|"
If LeftType = tValue Then
LeftList$ = Left & sep
ElseIf LeftType = tTree Then
LeftList = Left.GetList & sep
End If
If RightType = tValue Then
RightList$ = sep & Right
ElseIf RightType = tTree Then
RightList = sep & Right.GetList
End If
GetList = LeftList & Center & RightList
End Function
'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")