|
Membre Expert
Inscription : avril 2006 Messages : 1 318 Détails du profil  Informations forums : Inscription : avril 2006 Messages : 1 318 Points : 1 591 Points : 1 591
|
Tri de tableaux de string ou de chaines de tokens selon ordre et type
bonjour,
ces fonctions permettent de Trier des tableaux de string ou des chaines de tokens selon un ordre et un type de donnée.
Code :
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
|
'---------------------------------------------------------------------------------------
' Projet : Tri de tableaux de string ou de chaines de tokens selon ordre et type
' Création : Le mercredi 22 août 2007
' Auteur : P.B. [Philben]
'---------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
' Types de tri autorisés
Public Enum eTypeTri
eTexte
eBinTexte
eEntier
eReel
eDate
eLongueur
eBooléen
End Enum
Public Enum eOrdreTri
eCroissant
eDecroissant
End Enum
'---------------------------------------------------------------------------------------
' Procédure : TriChaine [Function]
' Retour : Variant
' Version : 1.0
' Auteur : P.B. [Philben]
' Création/Maj : Le mercredi 22 août 2007 à 01:58
' Objet : Trier une chaine de tokens composée ou non de sous-tokens selon
' : un ordre choisi et un type de token (texte, entier, réel, date,...)
' Historique :
'---------------------------------------------------------------------------------------
Public Function TriChaine(ByVal vChaine As Variant, _
ByVal sSep As String, _
Optional ByVal eType As eTypeTri = eTypeTri.eTexte, _
Optional ByVal eOrdre As eOrdreTri = eOrdreTri.eCroissant, _
Optional ByVal bNoMoveFirst As Boolean = False, _
Optional ByVal iNbColonnes As Integer = 0, _
Optional ByVal sSepColonnes As String, _
Optional ByVal iNumColonneTri As Integer = 0, _
Optional ByRef bIsErreur As Boolean) _
As Variant
Dim asTab() As String
Dim sDeb As String, sFin As String, sTmpSep As String
Dim lDeb As Long, lLenChaine As Long, lTmpPos As Long, lUb As Long
Dim iLenSep As Integer, i As Integer, j As Integer, iCountCol As Integer
bIsErreur = False
If Nz(Len(vChaine)) > 1 And Len(sSep) Then
If Left$(sSep, 1) <> " " Then vChaine = LTrim(vChaine)
If Right$(sSep, 1) <> " " Then vChaine = RTrim(vChaine)
lDeb = 1
lLenChaine = Len(vChaine)
iLenSep = Len(sSep)
If Left(vChaine, iLenSep) = sSep Then
lDeb = iLenSep + 1
sDeb = sSep
End If
If Right(vChaine, iLenSep) = sSep Then
lLenChaine = lLenChaine - lDeb - iLenSep + 1
sFin = sSep
End If
If eType = eTypeTri.eReel And (sSep = "." Or sSep = ",") Then bIsErreur = True
If iNbColonnes > 1 Then
If iNumColonneTri < 1 Or iNumColonneTri > iNbColonnes Or _
Len(sSepColonnes) = 0 Then
bIsErreur = True
Else
If sSep = sSepColonnes Then
i = 123
Do
For j = 123 To 255
sSepColonnes = sTmpSep & Chr(j)
If InStr(lDeb, vChaine, sSepColonnes) = 0 Then Exit For
Next j
If j > 255 Then
If Len(sSepColonnes) > 3 Then
bIsErreur = True
Else
sTmpSep = Left$(sSepColonnes, Len(sSepColonnes) - 1) & Chr(j)
i = IIf(i = 255, 123, i + 1)
End If
End If
Loop While j > 255 And Not bIsErreur
If Not bIsErreur Then
lTmpPos = lDeb
iCountCol = 0
lTmpPos = InStr(lTmpPos, vChaine, sSep)
While lTmpPos > 0
iCountCol = iCountCol + 1
If iCountCol = iNbColonnes Then
vChaine = Left(vChaine, lTmpPos - 1) & _
Replace(vChaine, sSep, sSepColonnes, lTmpPos, 1)
iCountCol = 0
End If
lTmpPos = InStr(lTmpPos + 1, vChaine, sSep)
Wend
sTmpSep = sSep
sSep = sSepColonnes
sSepColonnes = sTmpSep
End If
End If
End If
Else
sSepColonnes = sSep
End If
If bNoMoveFirst Then
lTmpPos = InStr(lDeb, vChaine, sSep)
If lTmpPos Then
lDeb = lTmpPos + iLenSep
lLenChaine = lLenChaine - lDeb + 1
sDeb = Left(vChaine, lDeb - 2) & sSepColonnes
End If
End If
If lLenChaine > lDeb And Not bIsErreur Then
asTab = Split(Mid(vChaine, lDeb, lLenChaine), sSep)
lUb = UBound(asTab)
If lUb > 0 Then
If iNbColonnes <= 1 Then
UnivTriTableau asTab, eType, eOrdre, 0, lUb
ElseIf (UBound(asTab) + 1) Mod iNbColonnes = 0 Then
UnivTriTableauCol asTab, eType, eOrdre, , , iNumColonneTri, sSepColonnes
Else
bIsErreur = True
End If
End If
vChaine = sDeb & Join(asTab, sSepColonnes) & sFin
End If
Else
bIsErreur = True
End If
TriChaine = vChaine
End Function
'---------------------------------------------------------------------------------------
' Procédure : UnivTriTableau [Sub]
' Retour :
' Version : 1.0
' Auteur : P.B. [Philben]
' Création/Maj : Le mercredi 22 août 2007 à 02:05
' Objet : Tri complétement ou partiellement un tableau de string selon
' : un ordre choisi et un type de donnée (texte, entier, réel, date,...)
' : Tri Shell ayant un bon rapport poids/performance
' Historique :
'---------------------------------------------------------------------------------------
Public Sub UnivTriTableau(ByRef asTab() As String, _
ByVal eType As eTypeTri, _
ByVal eOrdre As eOrdreTri, _
Optional ByVal lLowerBound As Long = -1, _
Optional ByVal lUpperBound As Long = -1)
Dim i As Long, j As Long, lInc As Long, n As Long, lMin As Long
Dim vConvRef As Variant
Dim sRef As String
If lLowerBound = -1 Then lLowerBound = LBound(asTab)
If lUpperBound = -1 Then lUpperBound = UBound(asTab)
n = lUpperBound - lLowerBound + 1
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
sRef = asTab(i)
vConvRef = UTTConversion(sRef, eType)
Do While UTTCompare(vConvRef, UTTConversion(asTab(j - lInc), eType), eOrdre, eType)
asTab(j) = asTab(j - lInc)
j = j - lInc
If j < lMin Then Exit Do
Loop
asTab(j) = sRef
Next i
Wend
End Sub
'---------------------------------------------------------------------------------------
' Procédure : UnivTriTableauCol [Sub]
' Retour :
' Version : 1.0
' Auteur : P.B. [Philben]
' Création/Maj : Le mercredi 22 août 2007 à 02:05
' Objet : Tri complétement ou partiellement un tableau de string selon
' : un ordre choisi et un type de token (texte, entier, réel, date,...)
' : Permet de trier un tableau selon un numéro de sous-token choisi
' : Version plus polyvalente mais 3 fois moins rapide
' Historique :
'---------------------------------------------------------------------------------------
Public Sub UnivTriTableauCol(ByRef asTab() As String, _
ByVal eType As eTypeTri, _
ByVal eOrdre As eOrdreTri, _
Optional ByVal lLowerBound As Long = -1, _
Optional ByVal lUpperBound As Long = -1, _
Optional ByVal iNumColTri As Integer = 0, _
Optional ByVal sSepColonnes As String)
Dim i As Long, j As Long, lInc As Long, n As Long, lMin As Long
Dim vConvRef As Variant, vConvCur As Variant
Dim sRef As String
If lLowerBound = -1 Then lLowerBound = LBound(asTab)
If lUpperBound = -1 Then lUpperBound = UBound(asTab)
If iNumColTri > 0 Then iNumColTri = iNumColTri - 1
n = lUpperBound - lLowerBound + 1
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
sRef = asTab(i)
If iNumColTri = -1 Then
vConvRef = UTTConversion(sRef, eType)
vConvCur = UTTConversion(asTab(j - lInc), eType)
Else
vConvRef = UTTConversion(Split(sRef, sSepColonnes)(iNumColTri), eType)
vConvCur = UTTConversion(Split(asTab(j - lInc), sSepColonnes)(iNumColTri), eType)
End If
Do While UTTCompare(vConvRef, vConvCur, eOrdre, eType)
asTab(j) = asTab(j - lInc)
j = j - lInc
If j < lMin Then
Exit Do
ElseIf iNumColTri = -1 Then
vConvCur = UTTConversion(asTab(j - lInc), eType)
Else
vConvCur = UTTConversion(Split(asTab(j - lInc), sSepColonnes)(iNumColTri), eType)
End If
Loop
asTab(j) = sRef
Next i
Wend
End Sub
'---------------------------------------------------------------------------------------
' Procédure : UTTConversion [Function]
' Retour : Variant
' Version : 1.0
' Création/Maj : Le mercredi 22 août 2007 à 02:29
' Objet : Fonction appelée par UnivTriTableau... pour convertir les données
' Historique :
'---------------------------------------------------------------------------------------
Private Function UTTConversion(ByVal v As String, ByVal eType As eTypeTri) As Variant
If eType = eTypeTri.eTexte Or eType = eTypeTri.eBinTexte Then
UTTConversion = v
ElseIf Len(v) = 0 Then
UTTConversion = 0
Else
Select Case eType
Case eTypeTri.eEntier
UTTConversion = CLng(v)
Case eTypeTri.eReel
If InStr(v, ",") Then
UTTConversion = Val(Replace(v, ",", ".", , 1))
Else
UTTConversion = Val(v)
End If
Case eTypeTri.eDate
UTTConversion = DateValue(v)
Case eTypeTri.eBooléen
UTTConversion = CBool(v)
Case eTypeTri.eLongueur
UTTConversion = Len(v)
End Select
End If
End Function
'---------------------------------------------------------------------------------------
' Procédure : UTTCompare [Function]
' Retour : Boolean
' Version : 1.0
' Création/Maj : Le mercredi 22 août 2007 à 02:29
' Objet : Fonction appelée par UnivTriTableau... pour comparer les valeurs
' Historique :
'---------------------------------------------------------------------------------------
Private Function UTTCompare(ByVal v1 As Variant, ByVal v2 As Variant, _
ByVal eOrdre As eOrdreTri, ByVal eType As eTypeTri) As Boolean
Select Case eType
Case eTypeTri.eTexte
UTTCompare = (StrComp(v1, v2, vbTextCompare) = -1 Eqv eOrdre = eOrdreTri.eCroissant)
Case eTypeTri.eBinTexte
UTTCompare = (StrComp(v1, v2, vbBinaryCompare) = -1 Eqv eOrdre = eOrdreTri.eCroissant)
Case Else
UTTCompare = (v1 < v2 Eqv eOrdre = eOrdreTri.eCroissant)
End Select
End Function |
Un jeu de test :
Code :
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
Public Sub TestTri()
Dim s As Variant
Dim i As Long, j As Long
Dim t As Single
Dim c As String
Dim bIsErr As Boolean
Dim ast(3 To 10) As String
Randomize
Debug.Print "Tri décroissant partiel (dim 2,3,4) d'un tableau de string de booléen"
Debug.Print "---------------------------------------------------------------------"
For i = LBound(ast) To UBound(ast)
ast(i) = IIf(Rnd < 0.5, "vrai", "faux")
Next i
UnivTriTableau ast, eTypeTri.eBooléen, eOrdreTri.eDecroissant, 4, 6
s = ""
For i = LBound(ast) To UBound(ast)
s = s & ast(i) & vbTab
Next i
Debug.Print s
Debug.Print vbCrLf & "Performance du tri de texte (49 151 tokens)"
Debug.Print "--------------------------------------------"
s = ""
For i = 1 To 12
s = s & Rnd & "|"
Next i
For i = 1 To 12
s = s & s
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eTexte, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
DoEvents
Debug.Print vbCrLf & "Tri croissant d'une chaine de texte"
Debug.Print "-----------------------------------"
s = ""
For i = 1 To 500
s = s & Chr((122 - 48) * Rnd + 48) & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eTexte, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant d'une chaine de texte avec le premier token fixe"
Debug.Print "--------------------------------------------------------------"
s = ""
For i = 1 To 250
s = s & Chr((122 - 48) * Rnd + 48) & "|"
Next i
s = "Toujours en premier|" & s
t = Timer()
s = TriChaine(s, "|", eTypeTri.eTexte, eOrdreTri.eCroissant, True)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri décroissant d'une chaine de texte (comparaison binaire)"
Debug.Print "-----------------------------------------------------------"
s = ""
For i = 1 To 500
s = s & Chr((122 - 48) * Rnd + 48) & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eBinTexte, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri décroissant d'entiers"
Debug.Print "-------------------------"
s = ""
For i = 1 To 200
s = s & Int(2000 * Rnd - 1000) & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eEntier, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
DoEvents
Debug.Print vbCrLf & "Tri croissant de réels (séparateur décimal : ,)"
Debug.Print "-----------------------------------------------"
s = ""
For i = 1 To 100
s = s & (2000 * Rnd - 1000) & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eReel, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri décroissant de réels (séparateur décimal : .)"
Debug.Print "-------------------------------------------------"
s = ""
For i = 1 To 100
s = s & Replace((2000 * Rnd - 1000), ",", ".") & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eReel, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant de dates"
Debug.Print "----------------------"
s = ""
For i = 1 To 75
s = s & CDate(Date - i) & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eDate, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
DoEvents
Debug.Print vbCrLf & "Tri décroissant de dates et heures"
Debug.Print "----------------------------------"
s = ""
For i = 1 To 50
s = s & CDate(Now() - i) & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eDate, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant selon la longueur des tokens"
Debug.Print "------------------------------------------"
s = ""
For i = 1 To 60
c = ""
For j = 0 To (Rnd * 25)
c = c & Chr((122 - 48) * Rnd + 48)
Next j
s = s & c & "|"
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eLongueur, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant sur la deuxième colonne des tokens composés 3 colonnes "
Debug.Print "---------------------------------------------------------------------"
s = ""
For i = 1 To 450
If (i + 1) Mod 3 = 0 Then
s = s & Chr((90 - 65) * Rnd + 65) & "|"
Else
s = s & Chr((57 - 48) * Rnd + 48) & "|"
End If
Next i
t = Timer()
s = TriChaine(s, "|", eTypeTri.eBinTexte, eOrdreTri.eCroissant, , 3, "|", 2, bIsErr)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s), "Erreur :" & bIsErr
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
End Sub |
cordialement,
Philippe
|
22/08/2007, 09h11
00
