==========================================================
==========================================================
==========================================================
==========================================================
Code:
'Alphabetically sort the arrARFund array
Function DataListSort(arrARFund ,strSort)
'Input: arrARFund = Array of data items, strings or integers'Input: strSort = Sort method.
'Options: ASC (ascending) or DESC (descending)
'Output: Sorted Array
'Notes: This is currently only storing the first 10 characters.
'Change MaxCharacters to increase this limit to allow more precise sorting.
'This will also increase memory usage.
DataListSort = ""
strList = ""
strSort = Trim(UCase(strSort))
If Not strSort = "ASC" And Not strSort = "DESC" Then
strSort = "ASC"
End If
Const adVarChar = 1000 ' Set the data type to variant.
Const MaxCharacters = 20 ' Set the max num of characters to store
'Setup Data object and connection
Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "Items", adVarChar, MaxCharacters
DataList.Open
'Iterate through to add the array items to the record set
For Each item In arrARFund
DataList.AddNew
DataList("Items") = item
DataList.Update
Next
'Sort the record set
DataList.Sort = "Items" & " " & strSort
DataList.MoveFirst
DataListSort = DataList.GetRows()
DataList.Close
End Function==========================================================
Code:
function SortArray(arrARFund (),lnCol,lcType)
Dim lnCnti
Dim lnCntj
Dim lnSmallest_Value
Dim lnSmallest_J
Dim lnMin
Dim lnMax
Dim lcTemp
lnMin = lbound(arrARFund ,2)
lnMax = ubound(arrARFund ,2)
For lnCnti = lnMin To lnMax - 1
lnSmallest_Value = arrARFund (lnCol,lnCnti)
lnSmallest_J = lnCnti
For lnCntj = lnCnti + 1 To lnMax
if lcType = "" Then
' See if arrARFund (lnCntj) is smaller. changed To strComp to work With strings.
if strComp(arrARFund (lnCol,lnCntj),lnSmallest_Value,vbTextCompare) = -1 Then
' Save the new smallest value.
lnSmallest_Value = arrARFund (lnCol,lnCntj)
lnSmallest_J = lnCntj
End if
End if
if lcType = "date" Then
' See if arrARFund (lnCntj) is smaller. changed To Japan Dates to work With Dates.
lcstr1 = Replace(ConvertShortDate(arrARFund (lnCol,lnCntj)),"/","")
lcstr2 = Replace(ConvertShortDate(lnSmallest_Value),"/","")
lcback1 = Mid(lcstr1,5,4) & Mid(lcstr1,3,2) & Mid(lcstr1,1,2)
lcback2 = Mid(lcstr2,5,4) & Mid(lcstr2,3,2) & Mid(lcstr2,1,2)
if lcback1 < lcback2 Then
' Save the new smallest value.
lnSmallest_Value = arrARFund (lnCol,lnCntj)
lnSmallest_J = lnCntj
End if
End if
Next 'lnCntj
if lnSmallest_J <> lnCnti Then
' Swap items lnCnti and lnSmallest_J.
For intA = 0 To ubound(arrARFund ,1)
lcTemp = arrARFund (intA,lnSmallest_J)
arrARFund (intA,lnSmallest_J) = arrARFund (intA,lnCnti)
arrARFund (intA,lnCnti) = lcTemp
Next 'intA
End if
Next 'lnCnti
SortArray = arrARFund
End functionCode:
' sort a multi dem array
' modified to allow different cols to be the key for the sort.
' modified to sort dates properly
' modified to allow you to specify a sort direction 'a' or 'd'
' Fixed issue with not finding a column with data in it to identify the type.
' Fixed issue when tring to sort numbers.
' Fixed issue when sometimes it didn't compare the number properly. Casted to cdbl
' Useage arraysort(array to be sorted, column to sort on, direction to sort (a|d)
' By: Eric Repec
' InetSolution Inc
' http://www.inetsolution.com
function arraysort(arrARFund (),intSortCol,strDirection)
Dim i
Dim j
Dim value
Dim value_j
dim min
dim max
dim temp
dim datatype
dim intComp
dim intA
dim intCheckIndex
min = lbound(arrARFund ,2)
max = ubound(arrARFund ,2)
' check to see what direction you want to sort.
if lcase(strDirection) = "d" then
intComp = -1
else
intComp = 1
end if
if intSortCol < 0 or intSortCol > ubound(arrARFund ,1) then
arraysort = arrARFund
exit function
end if
' find the first item which has valid data in it to sort
intCheckIndex = min
while len(trim(arrARFund (intSortCol,intCheckIndex))) = 0 and intCheckIndex < ubound(arrARFund ,2)
intCheckIndex = intCheckIndex + 1
wend
if isDate(trim(arrARFund (intSortCol,intCheckIndex))) then
datatype = 1
else
if isNumeric(trim(arrARFund (intSortCol,intCheckIndex))) then
datatype = 2
else
datatype = 0
end if
end if
For i = min To max - 1
value = arrARFund (intSortCol,i)
value_j = i
For j = i + 1 To max
select case datatype
case 0
' See if arrARFund (j) is smaller. works with strings now.
If strComp(arrARFund (intSortCol,j),value,vbTextCompare) = intComp Then
' Save the new smallest value.
value = arrARFund (intSortCol,j)
value_j = j
End If
case 1
if intComp = -1 then
if DateDiff("s",arrARFund (intSortCol,j),value) > 0 then
' Save the new smallest value.
value = arrARFund (intSortCol,j)
value_j = j
end if
else
if DateDiff("s",arrARFund (intSortCol,j),value) < 0 then
' Save the new smallest value.
value = arrARFund (intSortCol,j)
value_j = j
end if
end if
case 2
if intComp = -1 then
if cdbl(arrARFund (intSortCol,j)) < cdbl(value) then
' Save the new smallest value.
value = arrARFund (intSortCol,j)
value_j = j
end if
else
if cdbl(arrARFund (intSortCol,j)) > cdbl(value) then
' Save the new smallest value.
value = arrARFund (intSortCol,j)
value_j = j
end if
end if
end select
Next 'j
If value_j <> i Then
' Swap items i and value_j.
for intA = 0 to ubound(arrARFund ,1)
temp = arrARFund (intA,value_j)
arrARFund (intA,value_j) = arrARFund (intA,i)
arrARFund (intA,i) = temp
next 'intA
End If
Next 'i
arraysort = arrARFund
End function