I have my below code and outer array is not comparing each value with the inner array. Outer array is comparing with the one value from the inside and moving to the next value in it.
testdata = {25,27,81,104,33,34,56,78,99,84}
testdata1 = {81,104}
For i = 0 To UBound(testdata) - 1
For j = 0 To UBound(testdata1) - 1
If testdata(i) = testdata1(j) Then
isFound = True
Call DB_Connectionwisdataflagupdation(sQuery,Para2,Para3,Para4,sValue)
'c=c+1
Exit for
End If
'isFound = True
isFound = False
Next
Next
Please help me to get the solution on this.
I made a couple minor changes to your code, mainly adjusting the indices on your For loops:
Dim i As Integer
Dim j As Integer
Dim isFound As Boolean
For i = LBound(testdata) To UBound(testdata)
For j = LBound(testdata1) To UBound(testdata1)
If testdata(i) = testdata1(j) Then
isFound = True
'Call DB_Connectionwisdataflagupdation(sQuery, Para2, Para3, Para4, sValue)
MsgBox testdata(i)
Exit For
End If
isFound = False
Next
Next
I want to check collection variable contains the key or not in visual basic 6.0
Below is the collection variable I am having
pcolFields As Collection
and I want to check whether it contains the field Event_Code. I am doing this as below but it not worked for me.
If IsMissing(pcolFields("Event_Code")) = False Then
'Do Something
End If
Here is an example solution with try-catch:
Private Function IsMissing(col As Collection, field As String)
On Error GoTo IsMissingError
Dim val As Variant
val = col(field)
IsMissing = False
Exit Function
IsMissingError:
IsMissing = True
End Function
Use it like this:
Private Sub Form_Load()
Dim x As New Collection
x.Add "val1", "key1"
Dim testkey As String
testkey = "key2"
If IsMissing(x, testkey) Then
Debug.Print "Key is Missing"
Else
Debug.Print "Val is " + x(testkey)
End If
Exit Sub
End Sub
You could also try a to Implement or Subclass the Collection and add a "has" Function
Collections are not useful if you need to check for existence, but they're useful for iteration. However, collections are sets of Variants and so are inherently slower than typed variables.
In nearly every case it's more useful (and more optimal) to use a typed array. If you need to have a keyed collection you should use the Dictionary object.
Some examples of general ways of using typed arrays:
Dim my_array() As Long ' Or whichever type you need
Dim my_array_size As Long
Dim index As Long
Dim position As Long
' Add new item (push)
ReDim Preserve my_array(my_array_size)
my_array(my_array_size) = 123456 ' something to add
my_array_size = my_array_size + 1
' Remove item (pop)
my_array_size = my_array_size - 1
If my_array_size > 0 Then
ReDim Preserve my_array(my_array_size - 1)
Else
Erase my_array
End If
' Remove item (any position)
position = 3 'item to remove
For index = position To my_array_size - 2
my_array(index) = my_array(index + 1)
Next
my_array_size = my_array_size - 1
ReDim Preserve my_array(my_array_size - 1)
' Insert item (any position)
ReDim Preserve my_array(my_array_size)
my_array_size = my_array_size + 1
For index = my_array_size - 1 To position + 1 Step -1
my_array(index) = my_array(index - 1)
Next
my_array(position) = 123456 ' something to insert
' Find item
For index = 0 To my_array_size - 1
If my_array(index) = 123456 Then
Exit For
End If
Next
If index < my_array_size Then
'found, position is in index
Else
'not found
End If
Whilst it may seem like a lot code. It is way faster. Intellisense will also work, which is a bonus. The only caveat is if you have very large data sets, then redim starts to get slow and you have to use slightly different techniques.
You can also use a Dictionary, be sure to include the Microsoft Scripting Runtime reference in your project:
Dim dict As New Dictionary
Dim value As Long
dict.Add "somekey", 123456
dict.Remove "somekey"
value = dict.Item("somekey")
If dict.Exists("somekey") Then
' found!
Else
' not found
End If
Dictionaries like collections just hold a bunch of Variants, so can hold objects etc.
We can check following code into vb.net code
If Collection.ContainsKey(KeyString) Then
'write code
End if
Collection is variable of Dictionary and KeyString is a key string which we need to find into collection
The method from efkah will fail if the Collection contains objects rather than primitive types. Here is a small adjustment:
'Test if a key is available in a collection
Public Function HasKey(coll As Collection, strKey As String) As Boolean
On Error GoTo IsMissingError
Dim val As Variant
' val = coll(strKey)
HasKey = IsObject(coll(strKey))
HasKey = True
On Error GoTo 0
Exit Function
IsMissingError:
HasKey = False
On Error GoTo 0
End Function
I have a folder that I will be looping through to process files differently based on their filenames. Doing good on my script (first one!), until I realized there will be filenames that have also have numbers representing priority. For example in the folder there may be:
'NV_CX67_mainx.dxf'
'NV_CX67_mainx1.dxf'
'NV_CX67_mainx2.dxf '
'NV_CX67_mainxroad.dxf'
'NV_CX67_motx.dxf'
'NV_CX67_resxroad.dxf'
The mainx, mainx1 and mainx2 are the same file type but mainx2 has priority and should be the only one processed. Currently, my statement is:
If Instr(1,FileRef, "mainx",1) then
How might I add a 2nd filter to process only the file with the highest number before moving onto the next file?
You are going to have run through the following process
Sort your input files
Loop through each file one by one
Compare the current file to the previous one you looked at minus the numbers to see if it greater.
Only process an item you have scanned all the similar items to ensure this one has the largest number
I wrote up an example below. Notice only NV_CX67_mainx4.dxf, and NV_CX67_mainxroad.dxf get processed:
Option Explicit
Dim i, sBaseFileName, sPrevFileName, prevBaseFile
sPrevFileName = "~"
prevBaseFile = "~"
Dim arr(5)
'Initialize test array. This will need to be sorted for this code to work properly
arr(0) = "NV_CX67_mainx.dxf"
arr(1) = "NV_CX67_mainx4.dxf"
arr(2) = "NV_CX67_mainx2.dxf"
arr(3) = "NV_CX67_mainxroad.dxf"
arr(4) = "NV_CX67_motx.dxf"
arr(5) = "NV_CX67_resxroad.dxf"
'Loop through the array
For i = LBound(arr) to UBound(arr)
If Instr(1, arr(i), "mainx",1) Then 'Check prev qualifier
sBaseFileName = getsBaseFileName(arr(i))
'First Case
If prevBaseFile = "~" Then
prevBaseFile = sBaseFileName
sPrevFileName = arr(i)
'Tie - Figure out which one to keep based on number at end of file name
ElseIf prevBaseFile = sBaseFileName Then
sPrevFileName = GetMaxFile(sPrevFileName, arr(i))
prevBaseFile = getsBaseFileName(sPrevFileName)
'New Case - Process prev case
Else
'Process File
MsgBox ("Processing " + sPrevFileName)
'Capture new current file for future processing
sPrevFileName = arr(i)
prevBaseFile = getsBaseFileName(sPrevFileName)
End If
End If
Next
'If last file was valid process it
If sPrevFileName <> "~" Then
MsgBox ("Processing " + sPrevFileName)
End If
'Return the larger of the two files based on numbers at end.
'Note "file9.txt" > "file10.txt" in this code
Function GetMaxFile(sFile1, sFile2)
GetMaxFile = sFile1
If sFile2 > sFile1 Then
GetMaxFile = sFile2
End If
End Function
'Return the file without extension and trailing numbers
'getsBaseFileName("hello123.txt") returns "hello"
Function getsBaseFileName(sFile)
Dim sFileRev
Dim iPos
getsBaseFileName = sFile
sFileRev = StrReverse(sFile)
'Get rid of the extension
iPos = Instr(1, sFileRev, ".",1)
If iPos < 1 Then
Exit Function
End If
sFileRev = Right(sFileRev, Len(sFileRev)-iPos)
'Get rid of trailing numbers
Do
If InStr(1, "1234567890", Left(sFileRev, 1), 1) Then
sFileRev = Right(sFileRev, Len(sFileRev)-1)
Else
Exit Do
End If
Loop While(Len(sFileRev) > 0)
getsBaseFileName = StrReverse(sFileRev)
End Function
Ok so I've searched and searched and can't quite find what I'm looking for.
I have a workbook and what I'm basically trying to do is take the entries from certain ranges (Sheet1 - E4:E12, E14:E20, I4:I7, I9:I12, I14:I17, & I19:I21) and put them in a separate list on Sheet2. I then want the new list on Sheet2 to be sorted by how many times an entry appeared on Sheet1 as well as display the amount.
example http://demonik.doomdns.com/images/excel.png
Obviously as can be seen by the ranges I listed above, this sample is much smaller lol, was just having trouble trying to figure out how to describe everything and figured an image would help.
Basically I am trying to use VBA (the update would be initialized by hitting a button) to copy data from Sheet1 and put all the ranges into one list in Sheet2 that is sorted by how many times it appeared on Sheet1, and then alphabetically.
If a better discription is needed just comment and let me know, I've always been horrible at trying to describe stuff like this lol.
Thanks in advance!
Another detail: I cant have it search for specific things as the data in the ranges on Sheet1 may change. Everything must be dynamic.
I started out with this data
and used the following code to read it into an array, sort the array, and count the duplicate values, then output the result to sheet2
Sub Example()
Dim vCell As Range
Dim vRng() As Variant
Dim i As Integer
ReDim vRng(0 To 0) As Variant
Sheets("Sheet2").Cells.Delete
Sheets("Sheet1").Select
For Each vCell In ActiveSheet.UsedRange
If vCell.Value <> "" Then
ReDim Preserve vRng(0 To i) As Variant
vRng(i) = vCell.Value
i = i + 1
End If
Next
vRng = CountDuplicates(vRng)
Sheets("Sheet2").Select
Range(Cells(1, 1), Cells(UBound(vRng), UBound(vRng, 2))) = vRng
Rows(1).Insert
Range("A1:B1") = Array("Entry", "Times Entered")
ActiveSheet.UsedRange.Sort Range("B1"), xlDescending
End Sub
Function CountDuplicates(List() As Variant) As Variant()
Dim CurVal As String
Dim NxtVal As String
Dim DupCnt As Integer
Dim Result() As Variant
Dim i As Integer
Dim x As Integer
ReDim Result(1 To 2, 0 To 0) As Variant
List = SortAZ(List)
For i = 0 To UBound(List)
CurVal = List(i)
If i = UBound(List) Then
NxtVal = ""
Else
NxtVal = List(i + 1)
End If
If CurVal = NxtVal Then
DupCnt = DupCnt + 1
Else
DupCnt = DupCnt + 1
ReDim Preserve Result(1 To 2, 0 To x) As Variant
Result(1, x) = CurVal
Result(2, x) = DupCnt
x = x + 1
DupCnt = 0
End If
Next
Result = WorksheetFunction.Transpose(Result)
CountDuplicates = Result
End Function
Function SortAZ(MyArray() As Variant) As Variant()
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim x As Integer
Dim Temp As String
First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For x = i + 1 To Last
If MyArray(i) > MyArray(x) Then
Temp = MyArray(x)
MyArray(x) = MyArray(i)
MyArray(i) = Temp
End If
Next
Next
SortAZ = MyArray
End Function
End Result:
Here is a possible solution that I have started for you. What you are asking to be done gets rather complicated. Here is what I have so far:
Option Explicit
Sub test()
Dim items() As String
Dim itemCount() As String
Dim currCell As Range
Dim currString As String
Dim inArr As Boolean
Dim arrLength As Integer
Dim iterator As Integer
Dim x As Integer
Dim fullRange As Range
Set fullRange = Range("E1:E15")
iterator = 0
For Each cell In fullRange 'cycle through the range that has the values
inArr = False
For Each currString In items 'cycle through all values in array, if
'values is found in array, then inArr is set to true
If currCell.Value = currString Then 'if the value in the cell we
'are currently checking is in the array, then set inArr to true
inArr = True
End If
Next
If inArr = False Then 'if we did not find the value in the array
arrLength = arrLength + 1
ReDim Preserve items(arrLength) 'resize the array to fit the new values
items(iterator) = currCell.Value 'add the value to the array
iterator = iterator + 1
End If
Next
'This where it gets tricky. Now that you have all unique values in the array,
'you will need to count how many times each value is in the range.
'You can either make another array to hold those values or you can
'put those counts on the sheet somewhere to store them and access them later.
'This is tough stuff! It is not easy what you need to be done.
For x = 1 To UBound(items)
Next
End Sub
All that this does so far is get unique values into the array so that you can count how many times each one is in the range.
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
From microsoft
Sorting arrays in VBScript has never been easy; that’s because VBScript doesn’t have a sort command of any kind. In turn, that always meant that VBScript scripters were forced to write their own sort routines, be that a bubble sort routine, a heap sort, a quicksort, or some other type of sorting algorithm.
So (using .Net as it is installed on my 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
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
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
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.
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
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.
VBScript does not have a method for sorting arrays so you've got two options:
Writing a sorting function like mergesort, from ground up.
Use the JScript tip from this article
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>"
An old but still asked question. People posted links to this solution that are broken nowadays, so I post an example:
You can use ScriptControl to access JScript's array sort
You can provide your own jscript sorting function.
Unfortunateluy it works only in the 32 bit version of wsh...
a=split("this is a javascript array sort demo"," ")
wscript.echo vbcrlf & "alphabeticaly"&vbcrlf
a=sort(a)
for each i in a
wscript.echo i
next
wscript.echo vbcrlf & "by length"&vbcrlf
a=sortbylength(a)
for each i in a
wscript.echo i
next
function sort(a)
with createobject("ScriptControl")
.Language = "JScript"
.AddCode "function sortvbs(a) {return a.toArray().sort().join('\b')}"
sort= split(.Run("sortvbs",a),chr(8))
End With
end function
function sortbylength(a)
with createobject("ScriptControl")
.Language = "JScript"
.AddCode "function lensort(a,b){return((('' + a).length > ('' + b).length) ? 1 : ((('' + a).length < ('' + b).length) ? -1 : 0))}"
.Addcode "function sortvbs(a) {return a.toArray().sort(lensort).join('\b')}"
sortbylength= split(.Run("sortvbs",a),chr(8))
End With
end function
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.