Visto che non t'han risposto... ce provo io
Visto che sei pratico di matrici ne ho buttata giù una rozza.
Ho usato la UDF SortV presa da un sito che linko nel modulo delle macro.
Il foglio sviluppato lo trovi qui:
https://www.box.com/s/oz3kyxmnsoddu3r71mdlIl codice della UDF:
Option Explicit
Public Function SortV(ByRef sortrange As Variant, Optional SortBy As Long, Optional Order As Long = 1) As Variant
' http://newtonexcelbach.wordpress.com/2009/03/23/a-sort-function/
'Default:
'Sort Column =1
'Direction = 1 = Ascending anytingh else = descending
Dim iSpacing As Long
Dim iOuter As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iFinished As Long
Dim numcols As Long, Swap As Long, Swaprtn As Long
Dim Firstcol As Long, LastCol As Long
If TypeName(sortrange) = "Range" Then sortrange = sortrange.Value2
iLBound = LBound(sortrange)
iUBound = UBound(sortrange)
Firstcol = LBound(sortrange, 2)
LastCol = UBound(sortrange, 2)
If SortBy = 0 Then SortBy = Firstcol
'Initialise comb width
iSpacing = iUBound - iLBound
Do
If iSpacing > 1 Then
iSpacing = Int(iSpacing / 1.3)
If iSpacing = 0 Then
iSpacing = 1 'Dont go lower than 1
ElseIf iSpacing > 8 And iSpacing < 11 Then
iSpacing = 11 'This is a special number, goes faster than 9 and 10
End If
End If
'Always go down to 1 before attempting to exit
If iSpacing = 1 Then iFinished = 1
'Combing pass
For iOuter = iLBound To iUBound - iSpacing
iInner = iOuter + iSpacing
If Order = 1 Then
If sortrange(iOuter, SortBy) > sortrange(iInner, SortBy) Then Swap = 1
Else
If sortrange(iOuter, SortBy) < sortrange(iInner, SortBy) Then Swap = 1
End If
If Swap = 1 Then
Swaprtn = SwapRows(sortrange, iOuter, iInner, Firstcol, LastCol)
Swap = 0
'Not finished
iFinished = 0
End If
Next iOuter
Loop Until iFinished
SortV = sortrange
End Function
Function SwapRows(SwapArray As Variant, Row1 As Long, Row2 As Long, Firstcol As Long, LastCol As Long) As Long
Dim i As Long, Temp As Variant
For i = Firstcol To LastCol
Temp = SwapArray(Row1, i)
SwapArray(Row1, i) = SwapArray(Row2, i)
SwapArray(Row2, i) = Temp
Next i
If i = LastCol Then SwapRows = 0 Else SwapRows = i
End Function
Function QuickSort2DArray(VarArray As Variant, lSortColumn As Long, Optional sOrder As String = "A", _
Optional lngFirst As Long = -1, Optional lngLast As Long = -1) As Variant
' By RB Smissaert; http://groups.google.com/group/microsoft.public.excel.programming/browse_thread/thread/364c173e716998b2#
Dim c As Long
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
Dim varTempVal As Variant
Dim varTestVal As Variant
If lngFirst = -1 Then lngFirst = LBound(VarArray)
If lngLast = -1 Then lngLast = UBound(VarArray)
lngMiddle = (lngFirst + lngLast) / 2
varTestVal = VarArray(lngMiddle, lSortColumn)
lngLow = lngFirst
lngHigh = lngLast
Do
If sOrder = "A" Then
Do While VarArray(lngLow, lSortColumn) < varTestVal
lngLow = lngLow + 1
Loop
Do While VarArray(lngHigh, lSortColumn) > varTestVal
lngHigh = lngHigh - 1
Loop
Else
Do While VarArray(lngLow, lSortColumn) > varTestVal
lngLow = lngLow + 1
Loop
Do While VarArray(lngHigh, lSortColumn) < varTestVal
lngHigh = lngHigh - 1
Loop
End If
If (lngLow <= lngHigh) Then
'swap the array rows
'-------------------
For c = LBound(VarArray, 2) To UBound(VarArray, 2)
varTempVal = VarArray(lngLow, c)
VarArray(lngLow, c) = VarArray(lngHigh, c)
VarArray(lngHigh, c) = varTempVal
Next c
lngLow = lngLow + 1
lngHigh = lngHigh - 1
End If
Loop While (lngLow <= lngHigh)
If lngFirst < lngHigh Then
QuickSort2DArray VarArray, lSortColumn, sOrder, lngFirst, lngHigh
End If
If lngLow < lngLast Then
QuickSort2DArray VarArray, lSortColumn, sOrder, lngLow, lngLast
End If
End Function
Function QSort(sortrange As Variant, SortCol As Long, Order As Long)
Dim ierr As Long, AlphOrder As String
If Order = 1 Then AlphOrder = "A" Else AlphOrder = "D"
If TypeName(sortrange) = "Range" Then sortrange = sortrange.Value2
ierr = QuickSort2DArray(sortrange, SortCol, AlphOrder)
QSort = sortrange
End Function
Sub testsortv()
Dim sortrange As Variant, zsort() As Variant, first As Long, last As Long
Dim i As Long, j As Long
sortrange = [I8:O29].Value
ReDim zsort(0 To 21, 0 To 6)
For i = 1 To 22
For j = 1 To 7
zsort(i - 1, j - 1) = sortrange(i, j)
Next j
Next i
zsort = SortV(zsort, 6)
[I31:O50].Value = zsort
End SubMi pare funzioni.
Ho messo nel foglio la forma "lunga" e quella "compatta".
Poi ci sono anche alternative.
