وظيفة فرز مجموعة VBA؟
-
02-07-2019 - |
سؤال
أنا أبحث عن تنفيذ فرز لائق للصفائف في VBA.سيكون من المفضل الفرز السريع.أو أي دولة أخرى خوارزمية الفرز بخلاف الفقاعة أو الدمج سيكون كافيا.
يرجى ملاحظة أن هذا يعمل مع MS Project 2003، لذا يجب تجنب أي من وظائف Excel الأصلية وأي شيء يتعلق بـ .net.
المحلول
إلق نظرة هنا:
يحرر: تم إغلاق المصدر المشار إليه (allexperts.com) منذ ذلك الحين، ولكن إليك المصادر ذات الصلة مؤلف تعليقات:
هناك العديد من الخوارزميات المتاحة على الويب للفرز.الأكثر تنوعًا والأسرع عادةً هو خوارزمية الفرز السريع.فيما يلي وظيفة لذلك.
يمكنك تسميتها ببساطة عن طريق تمرير مجموعة من القيم (سلسلة أو رقمية؛لا يهم) مع حدود الصفيف السفلي (عادة
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 هنا.)
نصائح أخرى
لقد قمت بتحويل خوارزمية "الفرز السريع" إلى 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))
لقد قمت بنشر بعض التعليمات البرمجية للإجابة على سؤال ذي صلة على StackOverflow:
فرز مجموعة متعددة الأبعاد في VBA
تتضمن نماذج التعليمات البرمجية في هذا الموضوع ما يلي:
- مجموعة ناقلات Quicksort؛
- مصفوفة متعددة الأعمدة QuickSort؛
- فرز الفقاعات.
يعتبر Quicksort المُحسّن من Alain لامعًا للغاية:لقد قمت للتو بإجراء عملية تقسيم وتكرار أساسية، ولكن نموذج التعليمات البرمجية أعلاه يحتوي على وظيفة "بوابة" تقلل من المقارنات الزائدة عن الحاجة للقيم المكررة.من ناحية أخرى، أنا أقوم بالبرمجة لبرنامج Excel، ويوجد المزيد في طريقة الترميز الدفاعي - كن حذرًا، ستحتاج إليه إذا كانت المصفوفة الخاصة بك تحتوي على متغير "Empty()" الخبيث، والذي سيعطل وقتك.. .استخدم عوامل المقارنة واحجز الكود الخاص بك في حلقة لا نهائية.
لاحظ أن خوارزميات الفرز السريع - وأي خوارزمية متكررة - يمكنها ملء المكدس وتعطل برنامج Excel.إذا كانت مصفوفتك تحتوي على أقل من 1024 عضوًا، فسأستخدم نظام BubbleSort البدائي.
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 قد 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
هيريس كيفية القيام بذلك...
ملحوظة:
- لقد سرقت ميزة "الفرز السريع" من الإنترنت منذ فترة طويلة، ولست متأكدًا من أين الآن...
- لقد قمت بترجمة الدالة CompareNaturalNum التي تمت كتابتها في الأصل بلغة C من الإنترنت أيضًا.
- الفرق عن أنواع Q الأخرى:لا أقوم بتبديل القيم إذا كان BottomTemp = TopTemp
العدد الطبيعي الفرز السريع
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 الأخرى، فقد كتبت الوظيفة أدناه.
محددات:
- صفائف ثنائية الأبعاد؛
- الحد الأقصى 3 أعمدة كمفاتيح الفرز؛
- يعتمد على إكسل؛
تم اختبار الاتصال بـ Excel 2010 من 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
وهذا مثال على كيفية اختبار الوظيفة:
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، فيرجى النشر هنا إذا كانت هناك أية مشكلات.
أتساءل ماذا ستقول عن رمز فرز المصفوفة هذا.إنه سريع التنفيذ ويقوم بالمهمة ...لم يتم اختبارها للصفائف الكبيرة حتى الآن.إنه يعمل مع المصفوفات أحادية البعد، أما بالنسبة للقيم الإضافية متعددة الأبعاد، فيجب إنشاء مصفوفة إعادة تحديد الموقع (ببعد واحد أقل من المصفوفة الأولية).
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
هذا هو ما أستخدمه للفرز في الذاكرة - ويمكن توسيعه بسهولة لفرز مصفوفة.
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