VBA의 배열에 대한 적절한 정렬 구현을 찾고 있습니다. Quicksort가 선호됩니다. 또는 버블 또는 병합 이외의 다른 정렬 알고리즘으로 충분합니다.
이것은 MS Project 2003에서 작동하기위한 것이므로 Excel 기본 기능과 .net 관련 모든 것을 피해야합니다.
답변:
봐 여기 :
편집 : 참조 된 소스 (allexperts.com)는 이후 폐쇄되었지만 관련 작성자 의견 은 다음과 같습니다.
정렬을 위해 웹에서 사용할 수있는 많은 알고리즘이 있습니다. 가장 다양하고 일반적으로 가장 빠른 것은 Quicksort 알고리즘 입니다. 아래는이를위한 기능입니다.
Lower Array Boundary (일반적으로
0
) 및 Upper Array Boundary (예 :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
이것은 1 차원 (일명 "일반"?) 배열 에서만 작동 합니다. (여기에 작동하는 다차원 배열 QuickSort가 있습니다 .)
다른 사람이 원한다면 '빠른 빠른 정렬'알고리즘을 VBA로 변환했습니다.
Int / Long 배열에서 실행되도록 최적화했지만 임의의 비교 가능한 요소에서 작동하는 것으로 변환하는 것이 간단해야합니다.
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는 매우 반짝입니다. 저는 기본적인 split-and-recurse를 수행했지만 위의 코드 샘플에는 중복 된 값의 중복 비교를 줄이는 '게이트'기능이 있습니다. 반면에 필자는 Excel 용으로 코딩하고 있으며 방어적인 코딩 방식이 조금 더 있습니다. 경고를 받으십시오. 배열에 악성 'Empty ()'변형이 포함되어 있으면 While .. 비교 연산자를 완수하고 무한 루프에서 코드를 트랩하십시오.
빠른 정렬 알고리즘과 모든 재귀 알고리즘은 스택을 채우고 Excel을 중단시킬 수 있습니다. 배열에 1024 개 미만의 구성원이있는 경우 기본적인 BubbleSort를 사용합니다.
Public Sub QuickSortArray (ByRef SortArray As Variant, _ 옵션 lngMin As Long = -1, _ lngMax As Long 옵션 = -1, _ 선택적 lngColumn As Long = 0) On Error Resume Next
'2 차원 배열 정렬
'샘플 사용법 : 열 3의 내용을 기준으로 arrData 정렬 ' 'QuickSortArray arrData,,, 3
' 'Posted by Jim Rech 10/20/98 Excel. Programming'Modifications
, Nigel Heffernan :
''이스케이프가 비어있는 변형과 비교하지 못했습니다. ''방어 적 코딩 : 입력 확인
오랫동안 어둡게 긴 j 어둡게 Dim varMid As Variant Dim arrRowTemp As Variant 긴 lngColTemp 어둡게
IsEmpty (SortArray) 다음 서브 종료 End If
InStr (TypeName (SortArray), "()") <1 If InStr (TypeName (SortArray), "()") <1 Then 'IsArray () is some broken : type name에서 대괄호를 찾습니다. 서브 종료 End If
lngMin = -1이면 lngMin = LBound (SortArray, 1) End If
lngMax = -1이면 lngMax = UBound (SortArray, 1) End If
lngMin> = lngMax Then '정렬이 필요하지 않은 경우 서브 종료 End If
나는 = lngMin j = lngMax
varMid = 비어 있음 varMid = SortArray ((lngMin + lngMax) \ 2, lngColumn)
'우리는 목록 끝에'비어 있음 '및 잘못된 데이터 항목을 보냅니다. If IsObject (varMid) Then '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
If i <= j Then
'행 바꾸기 ReDim arrRowTemp (LBound (SortArray, 2) To 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 - 1
최종면
나아가 다
If (lngMin <j) Then Call QuickSortArray (SortArray, lngMin, j, lngColumn) If (i <lngMax) Then Call 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()
디버깅하는 동안 2 차원 배열을 빠르게 검사하는 데 유용한 함수라는 것을 잊었습니다 .
이 배열 정렬 코드에 대해 무엇을 말 하시겠습니까? 구현이 빠르며 작업을 수행합니다 ... 아직 대형 어레이에 대해 테스트하지 않았습니다. 다차원 추가 값 재배치 행렬을 빌드해야하기 때문에 1 차원 배열에서 작동합니다 (초기 배열보다 차원이 하나 더 적음).
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
여기서은 변형의 1 차원 배열이며 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(),"|")