Wie sortiere ich Arrays mit VBScript?

Question

Die Frage sagt alles wirklich, aber ...

Ich scanne durch eine Datei auf der Suche nach Zeilen, die ein bestimmtes Regex-Muster entsprechen, und dann möchte ich die Zeilen, die übereinstimmen, aber in alphabetischer Reihenfolge. Ich bin sicher, das ist trivial, aber Vbscript ist nicht mein Hintergrund

meine Array als

Dim lines(10000) 

definiert, wenn das einen Unterschied macht, und ich versuche, mein Skript von einer normalen cmd Aufforderung zur Ausführung

dank

Answer 1

Von microsoft

Arrays in VBScript Sortierung war nie einfach; Das liegt daran, dass VBScript keinen Sortierbefehl hat. Dies bedeutete wiederum, dass VBScript-Skripter gezwungen waren, ihre eigenen Sortierroutinen zu schreiben, sei es eine Bubble-Sortierroutine, eine Heap-Sortierung, ein Quicksort oder eine andere Art von Sortieralgorithmus.

So (mit .Net, wie es auf meinem PC installiert ist):

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

entweder Sie haben eine eigene Art von Hand zu schreiben, oder vielleicht versuchen, diese Technik:

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

Sie können Server-seitiges JavaScript mit VBScript frei mischen, also wo immer VBScript zu kurz kommt, wechseln Sie zu Javascript.

Answer 3

VBScript nicht über ein Verfahren zum Sortieren von Arrays, so dass Sie zwei Möglichkeiten haben:

• eine Sortierfunktion wie mergesort Schreiben, von Grund auf neu.
• Verwenden Sie die JScript Spitze von this article

Answer 4

ich etwas ähnlich, aber mit einem 2D-Array gestern nur hatte tatsächlich zu tun. Ich bin nicht so schnell auf VBScript und dieser Prozess hat mich wirklich festgefahren. Ich fand, dass die Artikel here sehr gut geschrieben waren und mich auf den Weg zum Sortieren im VBScript brachten.

Answer 5

Hier ist eine QuickSort, die ich für die Arrays geschrieben von der GetRows-Methode von ADODB.Recordset zurückgegeben habe.

'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

Getrennte Recordsets können nützlich sein.

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

Ich weiß, das ist ein ziemlich altes Thema, aber es könnte für jeden in der Zukunft nützlich sein. Das folgende Skript macht das, was der Typ mit vbscript erreichen wollte. wenn sortierte Terme, die in Großbuchstaben beginnen, Priorität haben.

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

Hier ist eine weitere VBScript-Implementierung von Quicksort. Dies ist der in-place, instabile Ansatz wie in Wikipedia definiert (siehe hier: http://en.wikipedia.org/wiki/Quicksort).Verwendet viel weniger Speicher (die ursprüngliche Implementierung erfordert, dass bei jeder Iteration obere und untere temporäre Speicher-Arrays erstellt werden, was im schlimmsten Fall die Speichergröße um n Terme erhöhen kann).

Bei aufsteigender Reihenfolge die Zeichen wechseln.

Wenn Sie Zeichen sortieren möchten, verwenden Sie Asc (ch) -Funktion.

'------------------------------------- 
' 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

Dies ist eine VBScript-Implementierung von merge sort.

'@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

Wenn große aufweist („breit“) -Arrays, anstatt für jedes Element aus einer langen Reihe von Daten bewegen, verwenden ein eindimensionales Array mit den Indizes des Arrays.

initialize ptr_arr mit 0,1,2,3, .. UBound (arr) dann Zugangsdaten mit

arr(field_index,ptr_arr(row_index)) 

statt

arr(field_index,row_index) 

und tauschen nur die Elemente der ptr_arr statt die Zeilen zu tauschen.

Wenn Sie die Array-Reihe sind die Verarbeitung von Zeile, zum Beispiel als eine Anzeige, können Sie die Suche aus der inneren Schleife nehmen:

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

Wenn Sie die Ausgabe werden die Linien wie auch immer, könnte man Führen Sie die Ausgabe über den Sortierbefehl aus. Nicht elegant, aber es erfordert nicht viel Arbeit:

cscript.exe //nologo YOUR-SCRIPT | Sort 

Hinweis // nologo die Logozeilen auslässt (Microsoft (R) Windows Script Host Version ... bla bla bla) erscheinen in der Mitte Ihrer sortierten Ausgabe. (Ich denke, MS weiß nicht, wofür Stderr ist.)

Weitere Informationen zur Sortierung finden Sie unter http://ss64.com/nt/sort.html.

/+ n ist die nützlichste Option, wenn Ihr Sortierschlüssel nicht in der ersten Spalte beginnt.

Vergleiche sind immer case-insensitive, die lahm ist.

Answer 12

Einige Old-School-Array-Sortierung. Natürlich werden nur Single-Dimension-Arrays sortiert.

‚C: \ DropBox \ Automation \ Bibliotheken \ 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