Función de clasificación de matriz VBA?

Estoy buscando una implementación de ordenamiento decente para matrices en VBA. Un Quicksort sería preferido. O cualquier otro algoritmo de ordenación que no sea burbuja o combinación sería suficiente.

Tenga en cuenta que esto es para trabajar con MS Project 2003, por lo que debe evitar cualquiera de las funciones nativas de Excel y todo lo relacionado con .net.

Eche un vistazo aquí :
Editar: la fuente referenciada (allexperts.com) se ha cerrado, pero aquí están los comentarios relevantes del autor :

Hay muchos algoritmos disponibles en la web para ordenar. El algoritmo Quicksort es el más versátil y generalmente el más rápido. A continuación se muestra una función para ello.

Llámelo simplemente pasando una matriz de valores (cadena o numérico, no importa) con el Límite inferior de la matriz (generalmente 0 ) y el Límite superior de la matriz (es decir, UBound(myArray) .

Ejemplo : Call QuickSort(myArray, 0, UBound(myArray))

Cuando myArray , myArray se ordenará y podrá hacer lo que quiera con él.
(Fuente: 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 

Tenga en cuenta que esto solo funciona con matrices unidimensionales (también conocidas como "normales"). (Aquí hay un Array QuickSort multidimensional en funcionamiento).

Convertí el algoritmo de “clasificación rápida rápida” a VBA, si alguien más lo quiere.

Lo tengo optimizado para ejecutar en una variedad de Int / Longs, pero debería ser simple convertirlo a uno que funcione con elementos comparables arbitrarios.

 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 

Explicación en alemán, pero el código es una implementación in situ bien probada:

 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 

Invocado así:

 Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray)) 

Publiqué un código en respuesta a una pregunta relacionada en StackOverflow:

Ordenar una matriz multidimensional en VBA

Los ejemplos de código en ese hilo incluyen:

  1. Una matriz de vectores Quicksort;
  2. Una matriz de columnas múltiples QuickSort;
  3. Un BubbleSort.

El Quicksort optimizado de Alain es muy shiny: acabo de hacer un split-and-recurse básico, pero el ejemplo de código anterior tiene una función ‘gating’ que reduce las comparaciones redundantes de valores duplicados. Por otro lado, codifico Excel, y hay un poco más en el camino de la encoding defensiva – se advirtió, lo necesitarás si tu matriz contiene la perniciosa variante ‘Vacía ()’, que romperá tu Tiempo … . Buscamos operadores de comparación y atrapamos su código en un bucle infinito.

Tenga en cuenta que los algoritmos de quicksort y cualquier algoritmo recursivo pueden llenar la stack y bloquear Excel. Si su matriz tiene menos de 1024 miembros, utilizaría un BubbleSort rudimentario.

 Public Sub QuickSortArray (ByRef SortArray como variante, _
                                 Opcional lngMin As Long = -1, _ 
                                 Opcional lngMax As Long = -1, _ 
                                 Opcional lngColumn As Long = 0)
 On Error Resume Next 
'Ordenar una matriz bidimensional
'Uso de la muestra: ordena arrData por el contenido de la columna 3 ' 'QuickSortArray arrData,,, 3
' 'Publicado por Jim Rech 20/10/98 Excel.Progtwigción
'Modificaciones, Nigel Heffernan:
'' Comparación de error de escape con la variante vacía '' Codificación defensiva: entradas de verificación
Dim i As Long Dim j Tan largo Dim varMid como variante Dim arrRowTemp como variante Dim lngColTemp As Long

Si IsEmpty (SortArray) Entonces Salir Sub Terminara si
Si InStr (TypeName (SortArray), "()") <1 Entonces 'IsArray () está algo roto: busque corchetes en el nombre del tipo Salir Sub Terminara si
Si lngMin = -1 Entonces lngMin = LBound (SortArray, 1) Terminara si
Si lngMax = -1 Entonces lngMax = UBound (SortArray, 1) Terminara si
Si lngMin> = lngMax Then 'no se requiere clasificación Salir Sub Terminara si

i = lngMin j = lngMax
varMid = Vacío varMid = SortArray ((lngMin + lngMax) \ 2, lngColumn)
'Enviamos elementos de datos' Vacíos 'e inválidos al final de la lista: Si IsObject (varMid) Entonces 'tenga en cuenta que no verificamos isObject (SortArray (n)) - varMid podría recoger un miembro o propiedad predeterminado válido i = lngMax j = lngMin ElseIf IsEmpty (varMid) Entonces i = lngMax j = lngMin ElseIf IsNull (varMid) Entonces i = lngMax j = lngMin ElseIf varMid = "" Entonces i = lngMax j = lngMin ElseIf varType (varMid) = vbError Then i = lngMax j = lngMin ElseIf varType (varMid)> 17 Entonces i = lngMax j = lngMin Terminara si

Mientras yo <= j
Mientras SortArray (i, lngColumn) Mientras varMid lngMin j = j - 1 Encaminarse a

Si yo <= j Entonces
'Cambiar las filas ReDim arrRowTemp (LBound (SortArray, 2) Para UBound (SortArray, 2)) Para lngColTemp = LBound (SortArray, 2) Para UBound (SortArray, 2) arrRowTemp (lngColTemp) = SortArray (i, lngColTemp) SortArray (i, lngColTemp) = SortArray (j, lngColTemp) SortArray (j, lngColTemp) = arrRowTemp (lngColTemp) Siguiente lngColTemp Borrar arrRowTemp
i = i + 1 j = j - 1
Terminara si

Encaminarse a
If (lngMin
End Sub

Número natural (cadenas) Ordenar rápidamente

Solo para astackr sobre el tema. Normalmente, si ordena cadenas con números obtendrá algo como esto:

  Text1 Text10 Text100 Text11 Text2 Text20 

Pero realmente quieres que reconozca los valores numéricos y se clasifique como

  Text1 Text2 Text10 Text11 Text20 Text100 

He aquí cómo hacerlo …

Nota:

  • Robé Quick Sort de Internet hace mucho tiempo, no estoy seguro de dónde ahora …
  • También traduje la función CompareNaturalNum que originalmente se escribió en C desde Internet.
  • Diferencia de otras Q-Sorts: No cambio los valores si BottomTemp = TopTemp

Número natural de clasificación rápida

 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 

Comparación de números naturales (utilizada en clasificación rápida)

 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 (utilizado en 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 

No quería una solución basada en Excel, pero como tenía el mismo problema hoy y quería probar usando otras funciones de Office Office, escribí la siguiente función.

Limitaciones

  • Matrices bidimensionales;
  • un máximo de 3 columnas como claves de clasificación;
  • depende de Excel;

Probado llamando a Excel 2010 desde 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 

Este es un ejemplo de cómo probar la función:

 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 

Si alguien lo prueba usando otras versiones de la oficina, publique aquí si hay algún problema.

Creo que mi código (probado) es más “educado”, suponiendo que cuanto más simple, mejor .

 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 

Me pregunto qué dirías sobre este código de clasificación de matriz. Es rápido para la implementación y cumple su función … todavía no se han probado las matrices de gran tamaño. Funciona para matrices unidimensionales, para los valores adicionales multidimensionales la matriz de reubicación necesitaría ser comstackda (con una dimensión menos que la matriz inicial).

  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 

Esto es lo que utilizo para clasificar en memoria: se puede expandir fácilmente para ordenar una matriz.

  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