I'm scanning through a file looking for lines that match a certain regex pattern, and then I want to print out the lines that match but in alphabetical order. I'm sure this is trivial but vbscript isn't my background
my array is defined as
Dim lines(10000)
if that makes any difference, and I'm trying to execute my script from a normal cmd prompt
Some old school array sorting. Of course this only sorts single dimension arrays.
'C:\DropBox\Automation\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
You either have to write your own sort by hand, or maybe try this technique:
http://www.aspfaqs.com/aspfaqs/ShowFAQ.asp?FAQID=83
You can freely intermix server side javascript with VBScript, so wherever VBScript falls short, switch to javascript.
This is a vbscript implementation of 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
Disconnected recordsets can be useful.
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
Here is a QuickSort that I wrote for the arrays returned from the GetRows method of 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
I actually just had to do something similar but with a 2D array yesterday. I am not that up to speed on vbscript and this process really bogged me down. I found that the articles here were very well written and got me on the road to sorting in vbscript.
When having large ("wide") arrays, instead of moving each element of a long row of data around, use a one-dimensional array with indexes of the array.
initialize ptr_arr with 0,1,2,3,..uBound(arr) then access data with
arr(field_index,ptr_arr(row_index))
instead of
arr(field_index,row_index)
and just swap the elements of ptr_arr instead of swapping the rows.
If you are processing the array row by row, eg displaying it as a , you can take the lookout out of the inner loop:
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>"
Here is a QuickSort that I wrote for the arrays returned from the GetRows method of 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
This is a vbscript implementation of 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
Here's another vbscript implementation of quicksort. This is the in-place, unstable approach as defined in wikipedia (see here: http://en.wikipedia.org/wiki/Quicksort). Uses much less memory (original implementation requires upper and lower temporary storage arrays to be created upon every iteration, which can increase memory size by n terms in the worst case).
For ascending order, switch the signs.
If you want to sort characters, use Asc(ch) function.
'-------------------------------------
' 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
You either have to write your own sort by hand, or maybe try this technique:
http://www.aspfaqs.com/aspfaqs/ShowFAQ.asp?FAQID=83
You can freely intermix server side javascript with VBScript, so wherever VBScript falls short, switch to javascript.
When having large ("wide") arrays, instead of moving each element of a long row of data around, use a one-dimensional array with indexes of the array.
initialize ptr_arr with 0,1,2,3,..uBound(arr) then access data with
arr(field_index,ptr_arr(row_index))
instead of
arr(field_index,row_index)
and just swap the elements of ptr_arr instead of swapping the rows.
If you are processing the array row by row, eg displaying it as a , you can take the lookout out of the inner loop:
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>"
Disconnected recordsets can be useful.
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
You either have to write your own sort by hand, or maybe try this technique:
http://www.aspfaqs.com/aspfaqs/ShowFAQ.asp?FAQID=83
You can freely intermix server side javascript with VBScript, so wherever VBScript falls short, switch to javascript.
VBScript does not have a method for sorting arrays so you've got two options:
Here's another vbscript implementation of quicksort. This is the in-place, unstable approach as defined in wikipedia (see here: http://en.wikipedia.org/wiki/Quicksort). Uses much less memory (original implementation requires upper and lower temporary storage arrays to be created upon every iteration, which can increase memory size by n terms in the worst case).
For ascending order, switch the signs.
If you want to sort characters, use Asc(ch) function.
'-------------------------------------
' 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
I know this is a pretty old topic but it might come in handy for anyone in the future. the script below does what the fella was trying to achieve purely using vbscript. when sorted terms starting in capital letters will have priority.
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
Disconnected recordsets can be useful.
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
I know this is a pretty old topic but it might come in handy for anyone in the future. the script below does what the fella was trying to achieve purely using vbscript. when sorted terms starting in capital letters will have priority.
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
If you are going to output the lines anyway, you could run the output through the sort command. Not elegant, but it does not require much work:
cscript.exe //nologo YOUR-SCRIPT | Sort
Note //nologo omits the logo lines (Microsoft (R) Windows Script Host Version... blah blah blah) from appearing in the middle of your sorted output. (I guess MS does not know what stderr is for.)
See http://ss64.com/nt/sort.html for details on sort.
/+n is the most useful option if your sort key does not start in the first column.
Compares are always case-insensitive, which is lame.
Here is a QuickSort that I wrote for the arrays returned from the GetRows method of 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
I actually just had to do something similar but with a 2D array yesterday. I am not that up to speed on vbscript and this process really bogged me down. I found that the articles here were very well written and got me on the road to sorting in vbscript.
Disconnected recordsets can be useful.
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
If you are going to output the lines anyway, you could run the output through the sort command. Not elegant, but it does not require much work:
cscript.exe //nologo YOUR-SCRIPT | Sort
Note //nologo omits the logo lines (Microsoft (R) Windows Script Host Version... blah blah blah) from appearing in the middle of your sorted output. (I guess MS does not know what stderr is for.)
See http://ss64.com/nt/sort.html for details on sort.
/+n is the most useful option if your sort key does not start in the first column.
Compares are always case-insensitive, which is lame.
VBScript does not have a method for sorting arrays so you've got two options:
Some old school array sorting. Of course this only sorts single dimension arrays.
'C:\DropBox\Automation\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
You either have to write your own sort by hand, or maybe try this technique:
http://www.aspfaqs.com/aspfaqs/ShowFAQ.asp?FAQID=83
You can freely intermix server side javascript with VBScript, so wherever VBScript falls short, switch to javascript.
I actually just had to do something similar but with a 2D array yesterday. I am not that up to speed on vbscript and this process really bogged me down. I found that the articles here were very well written and got me on the road to sorting in vbscript.
Source: Stackoverflow.com