Home |
Search |
Today's Posts |
|
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
This is a bit of a complex question, but let me try.
Firstly, I picked up a really neat trick from Jim Mack to alter the lBound of an array. Maybe one for Alan Beban, but I suppose the knows this already. This is the Sub I use now as the result of this tip: Private Declare Function VarPtrAry _ Lib "msvbvm60" _ Alias "VarPtr" (Ary() As Any) As Long Private Declare Sub CopyMemory _ Lib "kernel32" _ Alias "RtlMoveMemory" (Dest As Any, Src As Any, _ ByVal cBytes As Long) Function GetArrayDims(arr As Variant) As Integer '---------------------------------------' 'copied from Francesco Balena at: ' 'http://www.devx.com/vb2themax/Tip/18265' '---------------------------------------' Dim ptr As Long Dim VType As Integer Const VT_BYREF = &H4000& ' get the real VarType of the argument ' this is similar to VarType(), but returns also the VT_BYREF bit CopyMemory VType, arr, 2 ' exit if not an array If (VType And vbArray) = 0 Then Exit Function End If ' get the address of the SAFEARRAY descriptor ' this is stored in the second half of the ' Variant parameter that has received the array CopyMemory ptr, ByVal VarPtr(arr) + 8, 4 ' see whether the routine was passed a Variant ' that contains an array, rather than directly an array ' in the former case ptr already points to the SA structure. ' Thanks to Monte Hansen for this fix If (VType And VT_BYREF) Then ' ptr is a pointer to a pointer CopyMemory ptr, ByVal ptr, 4 End If ' get the address of the SAFEARRAY structure ' this is stored in the descriptor ' get the first word of the SAFEARRAY structure ' which holds the number of dimensions ' ...but first check that saAddr is non-zero, otherwise ' this routine bombs when the array is uninitialized ' (Thanks to VB2TheMax aficionado Thomas Eyde for ' suggesting this edit to the original routine.) If ptr Then CopyMemory GetArrayDims, ByVal ptr, 2 End If End Function Sub SetLBound(Ary() As Double, lNewLBound As Long) ' ' "As Double" for example only -- use your specific type ' ' Note that this won't work for string() or UDT() with strings ' ' Sets Ary's LBound to NewBound, returns previous LBound. Dim i As Integer Dim AryPtr As Long Dim PrevLBound As Long Dim iDims As Integer iDims = GetArrayDims(Ary) If iDims = 0 Then Exit Sub End If AryPtr = VarPtrAry(Ary) ' address of address of safearray struct CopyMemory AryPtr, ByVal AryPtr, 4 AryPtr = AryPtr + 20 ' pointer to safearray.bounds.lLbound CopyMemory PrevLBound, ByVal AryPtr, 4 'no point altering lBound to the existing lBound If PrevLBound = lNewLBound Then Exit Sub End If For i = 1 To iDims CopyMemory ByVal AryPtr + (i - 1) * 8, lNewLBound, 4 Next End Sub The last Sub needs to be specific for a specific datatype, so if you gave it an array of longs it would be: Sub SetLBound(Ary() As Long, lNewLBound As Long) Now I thought I could use this trick (altering the lBound of an array much faster than by any other method) to handle a little problem with the VSort function in Laurent Longre's .xll MoreFunc. This is that it alters 0-based arrays in 1-based arrays. This is the wrapper function for this VSort as I have it now: Function VSORTArray(ByRef arr As Variant, _ ByVal btCol1 As Byte, _ ByVal strSortType1 As String, _ Optional ByVal btCol2 As Byte = 0, _ Optional ByVal strSortType2 As String = "", _ Optional ByVal btCol3 As Byte = 0, _ Optional ByVal strSortType3 As String = "") As Variant '------------------------------------------------------------------ 'http://longre.free.fr/english/ 'Uses Laurent Longre's VSort function in the .xll add-in MoreFunc 'Will be about 4 to 5 times faster than a quicksort and can sort 'on multiple columns. 'Done up to 3 columns here, but can be done up to 14 columns '------------------------------------------------------------------ 'will sort an 0-based or 1-based 2-D array with up to 3 sort keys 'the field key has to be supplied as a byte, where the first column 'of the array is 1, even if it is an 0-based array 'the sort type has to be given as "a", "A" , "b" or "B" 'examples: 'sorting on 1 field: arr2 = VSORTArray(arr, 1, "A") 'sorting on 2 fields: arr2 = VSORTArray(arr, 2, "D", 5, "A") '------------------------------------------------------------------ Dim i As Long Dim c As Long Dim LB1 As Long Dim UB1 As Long Dim LB2 As Long Dim UB2 As Long Dim arrKey1 Dim arrKey2 Dim arrKey3 Dim btSortType1 As Byte Dim btSortType2 As Byte Dim btSortType3 As Byte Dim arrFinal Dim arrFinal2 LB1 = LBound(arr) UB1 = UBound(arr) LB2 = LBound(arr, 2) UB2 = UBound(arr, 2) 'make the array for key 1 '------------------------ ReDim arrKey1(LB1 To UB1, LB1 To LB1) For i = LB1 To UB1 arrKey1(i, LB1) = arr(i, btCol1 - (1 - LB1)) Next 'set the sort type for key 1 '--------------------------- If UCase(strSortType1) = "A" Then btSortType1 = 1 Else btSortType1 = 0 End If If Not btCol2 = 0 Then 'make the array for key 2 '------------------------ ReDim arrKey2(LB1 To UB1, LB1 To LB1) For i = LB1 To UB1 arrKey2(i, LB1) = arr(i, btCol2 - (1 - LB1)) Next 'set the sort type for key 2 '--------------------------- If UCase(strSortType2) = "A" Then btSortType2 = 1 Else btSortType2 = 0 End If End If If Not btCol3 = 0 Then 'make the array for key 3 '------------------------ ReDim arrKey3(LB1 To UB1, LB1 To LB1) For i = LB1 To UB1 arrKey3(i, LB1) = arr(i, btCol3 - (1 - LB1)) Next 'set the sort type for key 3 '--------------------------- If UCase(strSortType3) = "A" Then btSortType3 = 1 Else btSortType3 = 0 End If End If If Not strSortType3 = "" Then '3 fields to sort on '------------------- arrFinal = Application.Run([VSORT], arr, _ arrKey1, btSortType1, _ arrKey2, btSortType2, _ arrKey3, btSortType3) Else '2 fields to sort on '------------------- If Not strSortType2 = "" Then arrFinal = Application.Run([VSORT], arr, _ arrKey1, btSortType1, _ arrKey2, btSortType2) Else '1 field to sort on '------------------ arrFinal = Application.Run([VSORT], _ arr, arrKey1, btSortType1) End If End If If LB1 = 0 Then 'to revert back to an 0-based array '---------------------------------- ReDim arrFinal2(LB1 To UB1, LB2 To UB2) For i = LBound(arrFinal) To UBound(arrFinal) For c = LBound(arrFinal, 2) To UBound(arrFinal, 2) arrFinal2(i - (1 - LB1), c - (1 - LB2)) = arrFinal(i, c) Next Next VSORTArray = arrFinal2 Else VSORTArray = arrFinal End If End Function This works fine, but to be able to use the above lBound altering code when giving it an array of longs, arrFinal needs to be declared as an array of longs. This now is the trouble. Tried all sorts of constructions, but sofar haven't managed it yet. It looks VSort needs to be used as a function, so with the sorted array as the function result. Running it as a Sub doesn't work. Any suggestions how to do this? RBS |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
VSORT | Excel Discussion (Misc queries) | |||
Morefunc v3.241 and the latest Morefunc | Excel Worksheet Functions | |||
Syntax Laurent Longre's Morefunc VSORT with arrays? | Excel Programming | |||
Hash a range, output a Long Integer? | Excel Programming | |||
Help with 1 x 2 array output | Excel Programming |