Я ищу достойную реализацию сортировки массивов в VBA. Предпочтительнее быстрая сортировка. Или подойдет любой другой алгоритм сортировки, кроме пузырьков или слияния.
Обратите внимание, что это работает с MS Project 2003, поэтому следует избегать использования каких-либо встроенных функций Excel и всего, что связано с .NET.
Ответы:
Взгляните сюда :Изменить: указанный источник (allexperts.com) с тех пор закрыт, но вот соответствующие комментарии автора :
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 / 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.NETByVal
здесь будет работать (хотя в 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)
.Натуральные числа (строки) Быстрая сортировка
Просто чтобы перейти к теме. Обычно, если вы сортируете строки с числами, вы получите что-то вроде этого:
Но вы действительно хотите, чтобы он распознавал числовые значения и сортировался как
Вот как это сделать ...
Заметка:
Быстрая сортировка натуральных чисел
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:
Сортировка многомерного массива в VBA
Примеры кода в этом потоке включают:
Оптимизированная Quicksort Алена очень блестящая: я только что выполнил базовое разделение и рекурсию, но в приведенном выше примере кода есть функция «стробирования», которая сокращает избыточные сравнения повторяющихся значений. С другой стороны, я кодирую для Excel, и есть еще кое-что о способах защитного кодирования - будьте осторожны, он вам понадобится, если ваш массив содержит пагубный вариант 'Empty ()', который сломает ваш While .. • Сделайте операторы сравнения и замкните ваш код в бесконечный цикл.
Обратите внимание, что алгоритмы быстрой сортировки - и любой рекурсивный алгоритм - могут заполнить стек и привести к сбою Excel. Если в вашем массиве менее 1024 членов, я бы использовал элементарную BubbleSort.
источник
Вам не нужно решение на основе Excel, но поскольку сегодня у меня была такая же проблема, и я хотел протестировать с использованием других функций приложений Office, я написал функцию ниже.
Ограничения:
Протестирован вызов 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
Если кто-нибудь тестирует это на других версиях офиса, напишите здесь, если возникнут проблемы.
источник
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
источник
Реализация heapsort . Нестабильный алгоритм сортировки 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
источник
В некоторой степени связано, но я также искал собственное решение VBA для Excel, поскольку расширенные структуры данных (словари и т. Д.) Не работают в моей среде. Следующее реализует сортировку через двоичное дерево в 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(),"|")
источник