¿Cómo ordeno las matrices usando vbscript?

Question

La pregunta lo dice todo, pero ...

estoy exploración a través de un archivo en busca de líneas que responden a un determinado patrón de expresión, y luego me quiera imprimir las líneas que coinciden pero en orden alfabético. Estoy seguro que esto es trivial, pero VBScript no es mi fondo

mi matriz se define como

Dim lines(10000) 

si hay alguna diferencia, y estoy tratando de ejecutar mi script desde la línea de cmd normales

gracias

Answer 1

Desde microsoft

ordenar matrices en VBScript nunca ha sido fácil; eso es porque VBScript no tiene ningún tipo de comando de ordenación. A su vez, eso siempre significaba que los scripters de VBScript se vieron obligados a escribir sus propias rutinas de ordenación, ya sea una rutina de ordenación de burbujas, una ordenación de montones, una vía rápida o algún otro tipo de algoritmo de clasificación.

Así (usando .Net, ya que está instalado en mi PC):

Set outputLines = CreateObject("System.Collections.ArrayList") 

'add lines 
outputLines.Add output 
outputLines.Add output 

outputLines.Sort() 
For Each outputLine in outputLines 
    stdout.WriteLine outputLine 
Next 

Answer 2

que o bien tienen que escribir su propia especie a mano, o tal vez probar esta técnica:

http://www.aspfaqs.com/aspfaqs/ShowFAQ.asp?FAQID=83

Puede entremezclar libremente javascript del lado del servidor con VBScript, de modo que donde sea que VBScript se quede corto, cambie a javascript.

Answer 3

VBScript no tiene un método para ordenar matrices por lo que tiene dos opciones:

• Escribir una función de clasificación como mergesort, desde abajo hacia arriba.
• Utilice la punta de JScript this article

Answer 4

realidad, yo sólo tenía que hacer algo similar, pero con una matriz 2D ayer. No estoy tan al tanto de vbscript y este proceso realmente me empantanó. Descubrí que los artículos here estaban muy bien escritos y me ayudaron a ordenar vbscript.

Answer 5

Aquí hay una QuickSort que escribí para las matrices devueltas del método GetRows de ADODB.Recordset.

'Author:  Eric Weilnau 
'Date Written: 7/16/2003 
'Description: QuickSortDataArray sorts a data array using the QuickSort algorithm. 
'    Its arguments are the data array to be sorted, the low and high 
'    bound of the data array, the integer index of the column by which the 
'    data array should be sorted, and the string "asc" or "desc" for the 
'    sort order. 
' 
Sub QuickSortDataArray(dataArray, loBound, hiBound, sortField, sortOrder) 
    Dim pivot(), loSwap, hiSwap, count 
    ReDim pivot(UBound(dataArray)) 

    If hiBound - loBound = 1 Then 
     If (sortOrder = "asc" and dataArray(sortField,loBound) > dataArray(sortField,hiBound)) or (sortOrder = "desc" and dataArray(sortField,loBound) < dataArray(sortField,hiBound)) Then 
      Call SwapDataRows(dataArray, hiBound, loBound) 
     End If 
    End If 

    For count = 0 to UBound(dataArray) 
     pivot(count) = dataArray(count,int((loBound + hiBound)/2)) 
     dataArray(count,int((loBound + hiBound)/2)) = dataArray(count,loBound) 
     dataArray(count,loBound) = pivot(count) 
    Next 

    loSwap = loBound + 1 
    hiSwap = hiBound 

    Do 
     Do While (sortOrder = "asc" and dataArray(sortField,loSwap) <= pivot(sortField)) or sortOrder = "desc" and (dataArray(sortField,loSwap) >= pivot(sortField)) 
      loSwap = loSwap + 1 

      If loSwap > hiSwap Then 
       Exit Do 
      End If 
     Loop 

     Do While (sortOrder = "asc" and dataArray(sortField,hiSwap) > pivot(sortField)) or (sortOrder = "desc" and dataArray(sortField,hiSwap) < pivot(sortField)) 
      hiSwap = hiSwap - 1 
     Loop 

     If loSwap < hiSwap Then 
      Call SwapDataRows(dataArray,loSwap,hiSwap) 
     End If 
    Loop While loSwap < hiSwap 

    For count = 0 to Ubound(dataArray) 
     dataArray(count,loBound) = dataArray(count,hiSwap) 
     dataArray(count,hiSwap) = pivot(count) 
    Next 

    If loBound < (hiSwap - 1) Then 
     Call QuickSortDataArray(dataArray, loBound, hiSwap-1, sortField, sortOrder) 
    End If 

    If (hiSwap + 1) < hiBound Then 
     Call QuickSortDataArray(dataArray, hiSwap+1, hiBound, sortField, sortOrder) 
    End If 
End Sub 

Answer 6

Los registros desconectados pueden ser útiles.

Const adVarChar = 200 'the SQL datatype is varchar 

'Create a disconnected recordset 
Set rs = CreateObject("ADODB.RECORDSET") 
rs.Fields.append "SortField", adVarChar, 25 

rs.CursorType = adOpenStatic 
rs.Open 
rs.AddNew "SortField", "Some data" 
rs.Update 
rs.AddNew "SortField", "All data" 
rs.Update 

rs.Sort = "SortField" 

rs.MoveFirst 

Do Until rs.EOF 
    strList=strList & vbCrLf & rs.Fields("SortField")   
    rs.MoveNext 
Loop 

MsgBox strList 

Answer 7

Sé que este es un tema muy viejo, pero podría ser útil para cualquier persona en el futuro. el script a continuación hace lo que el tío estaba tratando de lograr usando vbscript. cuando los términos ordenados comenzando en mayúsculas tendrán prioridad.

for a = UBound(ArrayOfTerms) - 1 To 0 Step -1 
    for j= 0 to a 
     if ArrayOfTerms(j)>ArrayOfTerms(j+1) then 
      temp=ArrayOfTerms(j+1) 
      ArrayOfTerms(j+1)=ArrayOfTerms(j) 
      ArrayOfTerms(j)=temp 
     end if 
    next 
next 

Answer 8

Aquí hay otra implementación de vbscript de quicksort. Este es el enfoque in situ e inestable como se define en wikipedia (ver aquí: http://en.wikipedia.org/wiki/Quicksort).Utiliza mucha menos memoria (la implementación original requiere que se creen matrices de almacenamiento temporal superior e inferior en cada iteración, lo que puede aumentar el tamaño de la memoria en términos n en el peor de los casos).

Para orden ascendente, cambie los letreros.

Si desea ordenar caracteres, use la función Asc (ch).

'------------------------------------- 
' quicksort 
' Carlos Nunez, created: 25 April, 2010. 
' 
' NOTE: partition function also 
'   required 
'------------------------------------- 
function qsort(list, first, last) 
    Dim i, j 
    if (typeName(list) <> "Variant()" or ubound(list) = 0) then exit function  'list passed must be a collection or array. 

    'if the set size is less than 3, we can do a simple comparison sort. 
    if (last-first) < 3 then 
     for i = first to last 
      for j = first to last 
       if list(i) < list(j) then 
        swap list,i,j 
       end if 
      next 
     next 
    else 
     dim p_idx 

     'we need to set the pivot relative to the position of the subset currently being sorted. 
     'if the starting position of the subset is the first element of the whole set, then the pivot is the median of the subset. 
     'otherwise, the median is offset by the first position of the subset. 
     '------------------------------------------------------------------------------------------------------------------------- 
     if first-1 < 0 then 
      p_idx = round((last-first)/2,0) 
     else 
      p_idx = round(((first-1)+((last-first)/2)),0) 
     end if 

     dim p_nidx:  p_nidx = partition(list, first, last, p_idx) 
     if p_nidx = -1 then exit function 

     qsort list, first, p_nidx-1 
     qsort list, p_nidx+1, last 
    end if 
end function 


function partition(list, first, last, idx) 
    Dim i 
    partition = -1 

    dim p_val:  p_val = list(idx) 
    swap list,idx,last 
    dim swap_pos: swap_pos = first 
    for i = first to last-1 
     if list(i) <= p_val then 
      swap list,i,swap_pos 
      swap_pos = swap_pos + 1 
     end if 
    next 
    swap list,swap_pos,last 

    partition = swap_pos 
end function 

function swap(list,a_pos,b_pos) 
    dim tmp 
    tmp = list(a_pos) 
    list(a_pos) = list(b_pos) 
    list(b_pos) = tmp 
end function 

Answer 9

Esta es una implementación de vbscript del tipo merge.

'@Function Name: Sort 
'@Author: Lewis Gordon 
'@Creation Date: 4/26/12 
'@Description: Sorts a given array either in ascending or descending order, as specified by the 
'    order parameter. This array is then returned at the end of the function. 
'@Prerequisites: An array must be allocated and have all its values inputted. 
'@Parameters: 
' $ArrayToSort: This is the array that is being sorted. 
' $Order: This is the sorting order that the array will be sorted in. This parameter 
'    can either be "ASC" or "DESC" or ascending and descending, respectively. 
'@Notes: This uses merge sort under the hood. Also, this function has only been tested for 
'   integers and strings in the array. However, this should work for any data type that 
'   implements the greater than and less than comparators. This function also requires 
'   that the merge function is also present, as it is needed to complete the sort. 
'@Examples: 
' Dim i 
' Dim TestArray(50) 
' Randomize 
' For i=0 to UBound(TestArray) 
'  TestArray(i) = Int((100 - 0 + 1) * Rnd + 0) 
' Next 
' MsgBox Join(Sort(TestArray, "DESC")) 
' 
'@Return value: This function returns a sorted array in the specified order. 
'@Change History: None 

'The merge function. 
Public Function Merge(LeftArray, RightArray, Order) 
    'Declared variables 
    Dim FinalArray 
    Dim FinalArraySize 
    Dim i 
    Dim LArrayPosition 
    Dim RArrayPosition 

    'Variable initialization 
    LArrayPosition = 0 
    RArrayPosition = 0 

    'Calculate the expected size of the array based on the two smaller arrays. 
    FinalArraySize = UBound(LeftArray) + UBound(RightArray) + 1 
    ReDim FinalArray(FinalArraySize) 

    'This should go until we need to exit the function. 
    While True 

     'If we are done with all the values in the left array. Add the rest of the right array 
     'to the final array. 
     If LArrayPosition >= UBound(LeftArray)+1 Then 
      For i=RArrayPosition To UBound(RightArray) 
       FinalArray(LArrayPosition+i) = RightArray(i) 
      Next 
      Merge = FinalArray 
      Exit Function 

     'If we are done with all the values in the right array. Add the rest of the left array 
     'to the final array. 
     ElseIf RArrayPosition >= UBound(RightArray)+1 Then 
      For i=LArrayPosition To UBound(LeftArray) 
       FinalArray(i+RArrayPosition) = LeftArray(i) 
      Next 
      Merge = FinalArray 
      Exit Function 

     'For descending, if the current value of the left array is greater than the right array 
     'then add it to the final array. The position of the left array will then be incremented 
     'by one. 
     ElseIf LeftArray(LArrayPosition) > RightArray(RArrayPosition) And UCase(Order) = "DESC" Then 
      FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition) 
      LArrayPosition = LArrayPosition + 1 

     'For ascending, if the current value of the left array is less than the right array 
     'then add it to the final array. The position of the left array will then be incremented 
     'by one. 
     ElseIf LeftArray(LArrayPosition) < RightArray(RArrayPosition) And UCase(Order) = "ASC" Then 
      FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition) 
      LArrayPosition = LArrayPosition + 1 

     'For anything else that wasn't covered, add the current value of the right array to the 
     'final array. 
     Else 
      FinalArray(LArrayPosition+RArrayPosition) = RightArray(RArrayPosition) 
      RArrayPosition = RArrayPosition + 1 
     End If 
    Wend 
End Function 

'The main sort function. 
Public Function Sort(ArrayToSort, Order) 
    'Variable declaration. 
    Dim i 
    Dim LeftArray 
    Dim Modifier 
    Dim RightArray 

    'Check to make sure the order parameter is okay. 
    If Not UCase(Order)="ASC" And Not UCase(Order)="DESC" Then 
     Exit Function 
    End If 
    'If the array is a singleton or 0 then it is sorted. 
    If UBound(ArrayToSort) <= 0 Then 
     Sort = ArrayToSort 
     Exit Function 
    End If 

    'Setting up the modifier to help us split the array effectively since the round 
    'functions aren't helpful in VBScript. 
    If UBound(ArrayToSort) Mod 2 = 0 Then 
     Modifier = 1 
    Else 
     Modifier = 0 
    End If 

    'Setup the arrays to about half the size of the main array. 
    ReDim LeftArray(Fix(UBound(ArrayToSort)/2)) 
    ReDim RightArray(Fix(UBound(ArrayToSort)/2)-Modifier) 

    'Add the first half of the values to one array. 
    For i=0 To UBound(LeftArray) 
     LeftArray(i) = ArrayToSort(i) 
    Next 

    'Add the other half of the values to the other array. 
    For i=0 To UBound(RightArray) 
     RightArray(i) = ArrayToSort(i+Fix(UBound(ArrayToSort)/2)+1) 
    Next 

    'Merge the sorted arrays. 
    Sort = Merge(Sort(LeftArray, Order), Sort(RightArray, Order), Order) 
End Function 

Answer 10

Al tener grandes matrices ("ancho"), en lugar de mover cada elemento de una larga fila de datos alrededor de, utilizar una matriz unidimensional con los índices de la matriz.

ptr_arr initialize con 0,1,2,3, .. UBOUND (arr) entonces los datos de acceso con

arr(field_index,ptr_arr(row_index)) 

en lugar de

arr(field_index,row_index) 

y simplemente intercambiar los elementos de ptr_arr en vez de intercambiar las filas.

Si va a procesar la fila de la matriz por fila, por ejemplo, se presentan como una, se puede tomar el puesto de observación fuera del circuito interno:

max_col=uBound(arr,1) 
response.write "<table>" 
for n = 0 to uBound(arr,2) 
    response.write "<tr>" 
    row=ptr_arr(n) 
    for i=0 to max_col 
    response.write "<td>"&arr(i,row)&"</td>" 
    next 
    response.write "</tr> 
next 
response.write "</table>" 

Answer 11

Si van a la salida de las líneas de todos modos, usted podría ejecuta la salida a través del comando de ordenación. No es elegante, pero no requiere mucho trabajo:

cscript.exe //nologo YOUR-SCRIPT | Sort 

Nota // nologo omite las líneas de logotipo (Microsoft (R) Windows Script Host versión ... bla, bla, bla) se muestren en el medio de su salida ordenada. (Supongo que MS no sabe para qué sirve stderr).

Consulte http://ss64.com/nt/sort.html para obtener detalles sobre la ordenación.

/+ n es la opción más útil si su clave de clasificación no se inicia en la primera columna.

Las comparaciones son siempre case-insensitive, que es cojo.

Answer 12

Algunos clasificador de matriz de la vieja escuela. Por supuesto, esto solo ordena matrices de una dimensión.

'C: \ DropBox \ Automatización \ Libraries \ Array.vbs

Option Explicit 

Public Function Array_AdvancedBubbleSort(ByRef rarr_ArrayToSort(), ByVal rstr_SortOrder) 
' ================================================================================== 
' Date   : 12/09/1999 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Creates a sorted Array from a one dimensional array 
'      in Ascending (default) or Descending order based on the rstr_SortOrder. 
' Variables  : 
'     rarr_ArrayToSort()  The array to sort and return. 
'     rstr_SortOrder The order to sort in, default ascending or D for descending. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_AdvancedBubbleSort" 
    Dim bln_Sorted 
    Dim lng_Loop_01 
    Dim str_SortOrder 
    Dim str_Temp 

    bln_Sorted = False 
    str_SortOrder = Left(UCase(rstr_SortOrder), 1) 'We only need to know if the sort order is A(SENC) or D(ESEND)...and for that matter we really only need to know if it's D because we are defaulting to Ascending. 
    Do While (bln_Sorted = False) 
     bln_Sorted = True 
     str_Temp = "" 
     If (str_SortOrder = "D") Then 
      'Sort in descending order. 
      For lng_Loop_01 = LBound(rarr_ArrayToSort) To (UBound(rarr_ArrayToSort) - 1) 
       If (rarr_ArrayToSort(lng_Loop_01) < rarr_ArrayToSort(lng_Loop_01 + 1)) Then 
        bln_Sorted = False 
        str_Temp = rarr_ArrayToSort(lng_Loop_01) 
        rarr_ArrayToSort(lng_Loop_01) = rarr_ArrayToSort(lng_Loop_01 + 1) 
        rarr_ArrayToSort(lng_Loop_01 + 1) = str_Temp 
       End If 
       If (rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) > rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01)) Then 
        bln_Sorted = False 
        str_Temp = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) 
        rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01) 
        rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01) = str_Temp 
       End If 
      Next 
     Else 
      'Default to Ascending. 
      For lng_Loop_01 = LBound(rarr_ArrayToSort) To (UBound(rarr_ArrayToSort) - 1) 
       If (rarr_ArrayToSort(lng_Loop_01) > rarr_ArrayToSort(lng_Loop_01 + 1)) Then 
        bln_Sorted = False 
        str_Temp = rarr_ArrayToSort(lng_Loop_01) 
        rarr_ArrayToSort(lng_Loop_01) = rarr_ArrayToSort(lng_Loop_01 + 1) 
        rarr_ArrayToSort(lng_Loop_01 + 1) = str_Temp 
       End If 
       If (rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) < rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01)) Then 
        bln_Sorted = False 
        str_Temp = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) 
        rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01) 
        rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01) = str_Temp 
       End If 
      Next 
     End If 
    Loop 
End Function 

Public Function Array_BubbleSort(ByRef rarr_ArrayToSort()) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_BubbleSort" 
    Dim lng_Loop_01 
    Dim lng_Loop_02 
    Dim var_Temp 

    For lng_Loop_01 = (UBound(rarr_ArrayToSort) - 1) To 0 Step -1 
     For lng_Loop_02 = 0 To lng_Loop_01 
      If rarr_ArrayToSort(lng_Loop_02) > rarr_ArrayToSort(lng_Loop_02 + 1) Then 
       var_Temp = rarr_ArrayToSort(lng_Loop_02 + 1) 
       rarr_ArrayToSort(lng_Loop_02 + 1) = rarr_ArrayToSort(lng_Loop_02) 
       rarr_ArrayToSort(lng_Loop_02) = var_Temp 
      End If 
     Next 
    Next 
End Function 

Public Function Array_GetDimensions(ByVal rarr_Array) 
    Const const_FUNCTION_NAME = "Array_GetDimensions" 
    Dim int_Dimensions 
    Dim int_Result 
    Dim str_Dimensions 

    int_Result = 0 
    If IsArray(rarr_Array) Then 
     On Error Resume Next 
     Do 
      int_Dimensions = -2 
      int_Dimensions = UBound(rarr_Array, int_Result + 1) 
      If int_Dimensions > -2 Then 
       int_Result = int_Result + 1 
       If int_Result = 1 Then 
        str_Dimensions = str_Dimensions & int_Dimensions 
       Else 
        str_Dimensions = str_Dimensions & ":" & int_Dimensions 
       End If 
      End If 
     Loop Until int_Dimensions = -2 
     On Error GoTo 0 
    End If 
    Array_GetDimensions = int_Result ' & ";" & str_Dimensions 
End Function 

Public Function Array_GetUniqueCombinations(ByVal rarr_Fields, ByRef robj_Combinations) 
    Const const_FUNCTION_NAME = "Array_GetUniqueCombinations" 
    Dim int_Element 
    Dim str_Combination 

    On Error Resume Next 

    Array_GetUniqueCombinations = CBool(False) 
    For int_Element = LBound(rarr_Fields) To UBound(rarr_Fields) 
     str_Combination = rarr_Fields(int_Element) 
     Call robj_Combinations.Add(robj_Combinations.Count & ":" & str_Combination, 0) 
'  Call Array_GetUniqueCombinationsSub(rarr_Fields, robj_Combinations, int_Element) 
    Next 'int_Element 
    For int_Element = LBound(rarr_Fields) To UBound(rarr_Fields) 
     Call Array_GetUniqueCombinationsSub(rarr_Fields, robj_Combinations, int_Element) 
    Next 'int_Element 
    Array_GetUniqueCombinations = CBool(True) 
End Function 'Array_GetUniqueCombinations 

Public Function Array_GetUniqueCombinationsSub(ByVal rarr_Fields, ByRef robj_Combinations, ByRef rint_LBound) 
    Const const_FUNCTION_NAME = "Array_GetUniqueCombinationsSub" 
    Dim int_Element 
    Dim str_Combination 

    On Error Resume Next 

    Array_GetUniqueCombinationsSub = CBool(False) 
    str_Combination = rarr_Fields(rint_LBound) 
    For int_Element = (rint_LBound + 1) To UBound(rarr_Fields) 
     str_Combination = str_Combination & "," & rarr_Fields(int_Element) 
     Call robj_Combinations.Add(robj_Combinations.Count & ":" & str_Combination, str_Combination) 
    Next 'int_Element 
    Array_GetUniqueCombinationsSub = CBool(True) 
End Function 'Array_GetUniqueCombinationsSub 

Public Function Array_HeapSort(ByRef rarr_ArrayToSort()) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_HeapSort" 
    Dim lng_Loop_01 
    Dim var_Temp 
    Dim arr_Size 

    arr_Size = UBound(rarr_ArrayToSort) + 1 
    For lng_Loop_01 = ((arr_Size/2) - 1) To 0 Step -1 
     Call Array_SiftDown(rarr_ArrayToSort, lng_Loop_01, arr_Size) 
    Next 
    For lng_Loop_01 = (arr_Size - 1) To 1 Step -1 
     var_Temp = rarr_ArrayToSort(0) 
     rarr_ArrayToSort(0) = rarr_ArrayToSort(lng_Loop_01) 
     rarr_ArrayToSort(lng_Loop_01) = var_Temp 
     Call Array_SiftDown(rarr_ArrayToSort, 0, (lng_Loop_01 - 1)) 
    Next 
End Function 

Public Function Array_InsertionSort(ByRef rarr_ArrayToSort()) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_InsertionSort" 
    Dim lng_ElementCount 
    Dim lng_Loop_01 
    Dim lng_Loop_02 
    Dim lng_Index 

    lng_ElementCount = UBound(rarr_ArrayToSort) + 1 
    For lng_Loop_01 = 1 To (lng_ElementCount - 1) 
     lng_Index = rarr_ArrayToSort(lng_Loop_01) 
     lng_Loop_02 = lng_Loop_01 
     Do While lng_Loop_02 > 0 
      If rarr_ArrayToSort(lng_Loop_02 - 1) > lng_Index Then 
       rarr_ArrayToSort(lng_Loop_02) = rarr_ArrayToSort(lng_Loop_02 - 1) 
       lng_Loop_02 = (lng_Loop_02 - 1) 
      End If 
     Loop 
     rarr_ArrayToSort(lng_Loop_02) = lng_Index 
    Next 
End Function 

Private Function Array_Merge(ByRef rarr_ArrayToSort(), ByRef rarr_ArrayTemp(), ByVal rlng_Left, ByVal rlng_MiddleIndex, ByVal rlng_Right) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Merges an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_Merge" 
    Dim lng_Loop_01 
    Dim lng_LeftEnd 
    Dim lng_ElementCount 
    Dim lng_TempPos 

    lng_LeftEnd = (rlng_MiddleIndex - 1) 
    lng_TempPos = rlng_Left 
    lng_ElementCount = (rlng_Right - rlng_Left + 1) 
    Do While (rlng_Left <= lng_LeftEnd) _ 
    And (rlng_MiddleIndex <= rlng_Right) 
     If rarr_ArrayToSort(rlng_Left) <= rarr_ArrayToSort(rlng_MiddleIndex) Then 
      rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_Left) 
      lng_TempPos = (lng_TempPos + 1) 
      rlng_Left = (rlng_Left + 1) 
     Else 
      rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_MiddleIndex) 
      lng_TempPos = (lng_TempPos + 1) 
      rlng_MiddleIndex = (rlng_MiddleIndex + 1) 
     End If 
    Loop 
    Do While rlng_Left <= lng_LeftEnd 
     rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_Left) 
     rlng_Left = (rlng_Left + 1) 
     lng_TempPos = (lng_TempPos + 1) 
    Loop 
    Do While rlng_MiddleIndex <= rlng_Right 
     rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_MiddleIndex) 
     rlng_MiddleIndex = (rlng_MiddleIndex + 1) 
     lng_TempPos = (lng_TempPos + 1) 
    Loop 
    For lng_Loop_01 = 0 To (lng_ElementCount - 1) 
     rarr_ArrayToSort(rlng_Right) = rarr_ArrayTemp(rlng_Right) 
     rlng_Right = (rlng_Right - 1) 
    Next 
End Function 

Public Function Array_MergeSort(ByRef rarr_ArrayToSort(), ByRef rarr_ArrayTemp(), ByVal rlng_FirstIndex, ByVal rlng_LastIndex) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' Note   :The rarr_ArrayTemp array that is passed in has to be dimensionalized to the same size 
'       as the rarr_ArrayToSort array that is passed in prior to calling the function. 
'       Also the rlng_FirstIndex variable should be the value of the LBound(rarr_ArrayToSort) 
'       and the rlng_LastIndex variable should be the value of the UBound(rarr_ArrayToSort) 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_MergeSort" 
    Dim lng_MiddleIndex 

    If rlng_LastIndex > rlng_FirstIndex Then 
     ' Recursively sort the two halves of the list. 
     lng_MiddleIndex = ((rlng_FirstIndex + rlng_LastIndex)/2) 
     Call Array_MergeSort(rarr_ArrayToSort, rarr_ArrayTemp, rlng_FirstIndex, lng_MiddleIndex) 
     Call Array_MergeSort(rarr_ArrayToSort, rarr_ArrayTemp, lng_MiddleIndex + 1, rlng_LastIndex) 
     ' Merge the results. 
     Call Array_Merge(rarr_ArrayToSort, rarr_ArrayTemp, rlng_FirstIndex, lng_MiddleIndex + 1, rlng_LastIndex) 
    End If 
End Function 

Public Function Array_Push(ByRef rarr_Array, ByVal rstr_Value, ByVal rstr_Delimiter) 
    Const const_FUNCTION_NAME = "Array_Push" 
    Dim int_Loop 
    Dim str_Array_01 
    Dim str_Array_02 

    'If there is no delimiter passed in then set the default delimiter equal to a comma. 
    If rstr_Delimiter = "" Then 
     rstr_Delimiter = "," 
    End If 

    'Check to see if the rarr_Array is actually an Array. 
    If IsArray(rarr_Array) = True Then 
     'Verify that the rarr_Array variable is only a one dimensional array. 
     If Array_GetDimensions(rarr_Array) <> 1 Then 
      Array_Push = "ERR, the rarr_Array variable passed in was not a one dimensional array." 
      Exit Function 
     End If 
     If IsArray(rstr_Value) = True Then 
      'Verify that the rstr_Value variable is is only a one dimensional array. 
      If Array_GetDimensions(rstr_Value) <> 1 Then 
       Array_Push = "ERR, the rstr_Value variable passed in was not a one dimensional array." 
       Exit Function 
      End If 
      str_Array_01 = Split(rarr_Array, rstr_Delimiter) 
      str_Array_02 = Split(rstr_Value, rstr_Delimiter) 
      rarr_Array = Join(str_Array_01 & rstr_Delimiter & str_Array_02) 
     Else 
      On Error Resume Next 
      ReDim Preserve rarr_Array(UBound(rarr_Array) + 1) 
      If Err.Number <> 0 Then ' "Subscript out of range" An array that was passed in must have been Erased to re-create it with new elements (possibly when passing an array to be populated into a recursive function) 
       ReDim rarr_Array(0) 
       Err.Clear 
      End If 
      If IsObject(rstr_Value) = True Then 
       Set rarr_Array(UBound(rarr_Array)) = rstr_Value 
      Else 
       rarr_Array(UBound(rarr_Array)) = rstr_Value 
      End If 
     End If 
    Else 
     'Check to see if the rstr_Value is an Array. 
     If IsArray(rstr_Value) = True Then 
      'Verify that the rstr_Value variable is is only a one dimensional array. 
      If Array_GetDimensions(rstr_Value) <> 1 Then 
       Array_Push = "ERR, the rstr_Value variable passed in was not a one dimensional array." 
       Exit Function 
      End If 
      rarr_Array = rstr_Value 
     Else 
      rarr_Array = Split(rstr_Value, rstr_Delimiter) 
     End If 
    End If 
    Array_Push = UBound(rarr_Array) 
End Function 

Public Function Array_QuickSort(ByRef rarr_ArrayToSort(), ByVal rlng_Low, ByVal rlng_High) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' Note   :The rlng_Low variable should be the value of the LBound(rarr_ArrayToSort) 
'       and the rlng_High variable should be the value of the UBound(rarr_ArrayToSort) 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_QuickSort" 
    Dim var_Pivot 
    Dim lng_Swap 
    Dim lng_Low 
    Dim lng_High 

    lng_Low = rlng_Low 
    lng_High = rlng_High 
    var_Pivot = rarr_ArrayToSort((rlng_Low + rlng_High)/2) 
    Do While lng_Low <= lng_High 
     Do While (rarr_ArrayToSort(lng_Low) < var_Pivot _ 
     And lng_Low < rlng_High) 
      lng_Low = lng_Low + 1 
     Loop 
     Do While (var_Pivot < rarr_ArrayToSort(lng_High) _ 
     And lng_High > rlng_Low) 
      lng_High = (lng_High - 1) 
     Loop 
     If lng_Low <= lng_High Then 
      lng_Swap = rarr_ArrayToSort(lng_Low) 
      rarr_ArrayToSort(lng_Low) = rarr_ArrayToSort(lng_High) 
      rarr_ArrayToSort(lng_High) = lng_Swap 
      lng_Low = (lng_Low + 1) 
      lng_High = (lng_High - 1) 
     End If 
    Loop 
    If rlng_Low < lng_High Then 
     Call Array_QuickSort(rarr_ArrayToSort, rlng_Low, lng_High) 
    End If 
    If lng_Low < rlng_High Then 
     Call Array_QuickSort(rarr_ArrayToSort, lng_Low, rlng_High) 
    End If 
End Function 

Public Function Array_SelectionSort(ByRef rarr_ArrayToSort()) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_SelectionSort" 
    Dim lng_ElementCount 
    Dim lng_Loop_01 
    Dim lng_Loop_02 
    Dim lng_Min 
    Dim var_Temp 

    lng_ElementCount = UBound(rarr_ArrayToSort) + 1 
    For lng_Loop_01 = 0 To (lng_ElementCount - 2) 
     lng_Min = lng_Loop_01 
     For lng_Loop_02 = (lng_Loop_01 + 1) To lng_ElementCount - 1 
      If rarr_ArrayToSort(lng_Loop_02) < rarr_ArrayToSort(lng_Min) Then 
      lng_Min = lng_Loop_02 
      End If 
     Next 
     var_Temp = rarr_ArrayToSort(lng_Loop_01) 
     rarr_ArrayToSort(lng_Loop_01) = rarr_ArrayToSort(lng_Min) 
     rarr_ArrayToSort(lng_Min) = var_Temp 
    Next 
End Function 

Public Function Array_ShellSort(ByRef rarr_ArrayToSort()) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sorts an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_ShellSort" 
    Dim lng_Loop_01 
    Dim var_Temp 
    Dim lng_Hold 
    Dim lng_HValue 

    lng_HValue = LBound(rarr_ArrayToSort) 
    Do 
     lng_HValue = (3 * lng_HValue + 1) 
    Loop Until lng_HValue > UBound(rarr_ArrayToSort) 
    Do 
     lng_HValue = (lng_HValue/3) 
     For lng_Loop_01 = (lng_HValue + LBound(rarr_ArrayToSort)) To UBound(rarr_ArrayToSort) 
      var_Temp = rarr_ArrayToSort(lng_Loop_01) 
      lng_Hold = lng_Loop_01 
      Do While rarr_ArrayToSort(lng_Hold - lng_HValue) > var_Temp 
       rarr_ArrayToSort(lng_Hold) = rarr_ArrayToSort(lng_Hold - lng_HValue) 
       lng_Hold = (lng_Hold - lng_HValue) 
       If lng_Hold < lng_HValue Then 
        Exit Do 
       End If 
      Loop 
      rarr_ArrayToSort(lng_Hold) = var_Temp 
     Next 
    Loop Until lng_HValue = LBound(rarr_ArrayToSort) 
End Function 

Private Function Array_SiftDown(ByRef rarr_ArrayToSort(), ByVal rlng_Root, ByVal rlng_Bottom) 
' ================================================================================== 
' Date   : 03/18/2008 
' Author   : Christopher J. Scharer (CJS) 
' Description  : Sifts the elements down in an array. 
' ================================================================================== 
    Const const_FUNCTION_NAME = "Array_SiftDown" 
    Dim bln_Done 
    Dim max_Child 
    Dim var_Temp 

    bln_Done = False 
    Do While ((rlng_Root * 2) <= rlng_Bottom) _ 
    And bln_Done = False 
     If rlng_Root * 2 = rlng_Bottom Then 
      max_Child = (rlng_Root * 2) 
     ElseIf rarr_ArrayToSort(rlng_Root * 2) > rarr_ArrayToSort(rlng_Root * 2 + 1) Then 
      max_Child = (rlng_Root * 2) 
     Else 
      max_Child = (rlng_Root * 2 + 1) 
     End If 
     If rarr_ArrayToSort(rlng_Root) < rarr_ArrayToSort(max_Child) Then 
      var_Temp = rarr_ArrayToSort(rlng_Root) 
      rarr_ArrayToSort(rlng_Root) = rarr_ArrayToSort(max_Child) 
      rarr_ArrayToSort(max_Child) = var_Temp 
      rlng_Root = max_Child 
     Else 
      bln_Done = True 
     End If 
    Loop 
End Function