1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
|
Public Enum eOrdreTri
eCroissant
eDecroissant
End Enum
Public Enum eTypeVariant
eTexte
eBinTexte
eAutre
End Enum
'---------------------------------------------------------------------------------------
' Procédure : TriTableau2D [Sub]
' Retour :
' Version : 1.0
' Auteur : P.B. [Philben]
' Création/Maj : 27/08/07
' Objet : Tri complétement ou partiellement un tableau de Variants selon
' : un ordre choisi et un type de variant
' : Tri Shell ayant un bon rapport poids/performance
' Historique :
'---------------------------------------------------------------------------------------
Public Sub TriTableau2D(ByRef avTab() As Variant, _
ByVal eType As eTypeVariant, _
ByVal eOrdre As eOrdreTri, _
ByVal lNumColTri As Long, _
Optional ByVal lLowerBound As Long = -1, _
Optional ByVal lUpperBound As Long = -1)
Dim i As Long, j As Long, k As Long, l As Long, lInc As Long, n As Long
Dim lMin As Long, lLowerCol As Long, lUpperCol As Long
Dim avRefLigne As Variant
lLowerCol = LBound(avTab, 2)
lUpperCol = UBound(avTab, 2)
If lNumColTri < lLowerCol Or lNumColTri > lUpperCol Then Exit Sub
If lLowerBound = -1 Then lLowerBound = LBound(avTab)
If lUpperBound = -1 Then lUpperBound = UBound(avTab)
n = lUpperBound - lLowerBound + 1
ReDim avRefLigne(lLowerCol To lUpperCol)
lInc = 1
While lInc < n
lInc = lInc * 3 + 1
Wend
While lInc > 1
lInc = lInc / 3
lMin = lInc + lLowerBound
For i = lMin To lUpperBound
j = i
k = j - lInc
l = lLowerCol
While l <= lUpperCol
avRefLigne(l) = avTab(j, l)
l = l + 1
Wend
Do While TTCompare(avRefLigne(lNumColTri), avTab(k, lNumColTri), eType, eOrdre)
l = lLowerCol
While l <= lUpperCol
avTab(j, l) = avTab(k, l)
l = l + 1
Wend
j = j - lInc
If j < lMin Then Exit Do
k = j - lInc
Loop
l = lLowerCol
While l <= lUpperCol
avTab(j, l) = avRefLigne(l)
l = l + 1
Wend
Next i
Wend
End Sub
'---------------------------------------------------------------------------------------
' Procédure : TTCompare [Function]
' Retour : Boolean
' Version : 1.0
' Création/Maj : 27/08/07
' Objet : Fonction appelée par TriTableau2D pour comparer les valeurs
' Historique :
'---------------------------------------------------------------------------------------
Private Function TTCompare(ByVal v1 As Variant, ByVal v2 As Variant, _
ByVal eType As eTypeVariant, ByVal eOrdre As eOrdreTri) As Boolean
Dim iRes As Integer
Select Case eType
Case eTypeVariant.eTexte
iRes = StrComp(v1, v2, vbTextCompare)
TTCompare = (iRes = -1 And eOrdre = eOrdreTri.eCroissant) Xor _
(iRes = 1 And eOrdre = eOrdreTri.eDecroissant)
Case eTypeVariant.eBinTexte
iRes = StrComp(v1, v2, vbBinaryCompare)
TTCompare = (iRes = -1 And eOrdre = eOrdreTri.eCroissant) Xor _
(iRes = 1 And eOrdre = eOrdreTri.eDecroissant)
Case Else
TTCompare = (v1 < v2 And eOrdre = eOrdreTri.eCroissant) Xor _
(v1 > v2 And eOrdre = eOrdreTri.eDecroissant)
End Select
End Function |
Partager