[Toutes versions] trié tableau a plusieurs dimensions [Résolu]

[boboss123]

bonjour,

J'ai fais une fonction pour trier un tableau a plusieurs dimension
Je dois trier un tableau de 160000 lignes x 3 colonnes

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
 
' algo trie a bulle
Private Sub SortTable(ByRef table() As Double, numCol)
 
Dim i As Long
Dim j As Long
Dim colNbr As Long
Dim rowNbr As Long
 
colNbr = UBound(table, 2) - LBound(table, 2) + 1 ' nombre de colonnes
rowNbr = UBound(table, 1) - LBound(table, 1) + 1 ' nombre de lignes
 
 
For i = LBound(table, 1) To UBound(table, 1) - 1
    For j = LBound(table, 1) To UBound(table, 1) - 1
        If table(j, numCol) > table(j + 1, numCol) Then
            Call invertLine(table, j, j + 1)
        End If
    Next j
Next i
 
End Sub
 
' interverti deux lignes de tableaux
Private Sub invertLine(ByRef table() As Double, ind1 As Long, ind2 As Long)
 
Dim colFirst As Long
Dim tabTmp() As Double
 
colFirst = LBound(table, 2) ' indice de la première colonne
 
ReDim tabTmp(LBound(table, 2) To UBound(table, 2))
 
tabTmp(colFirst) = table(ind1, colFirst)
tabTmp(colFirst + 1) = table(ind1, colFirst + 1)
tabTmp(colFirst + 2) = table(ind1, colFirst + 2)
 
table(ind1, colFirst) = table(ind2, colFirst)
table(ind1, colFirst + 1) = table(ind2, colFirst + 1)
table(ind1, colFirst + 2) = table(ind2, colFirst + 2)
 
table(ind2, colFirst) = tabTmp(colFirst)
table(ind2, colFirst + 1) = tabTmp(colFirst + 1)
table(ind2, colFirst + 2) = tabTmp(colFirst + 2)
 
End Sub

=> le problème avec cette méthode, c'est que ça va beaucoup trop doucement : y a t-il moyen d'accélérer l'algo svp ?

Merci d'avance,

[mercatog]

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
'Tbl: le tableau à trier
'Col: Colonne de tri
'L: Lbound(Tbl)
'H: Ubound(Tbl)
 
Sub QuickSort(Tbl As Variant, ByVal Col As Byte, ByVal L As Long, ByVal H As Long)
Dim X As Double, Y As Double
Dim i As Long, j As Long
Dim mm As Byte
 
i = L
j = H
X = Tbl(Int((L + H) / 2), Col)
While (i <= j)
    While (Tbl(i, Col) < X And i < H)
        i = i + 1
    Wend
    While (X < Tbl(j, Col) And j > L)
        j = j - 1
    Wend
    If (i <= j) Then
        For mm = LBound(Tbl, 2) To UBound(Tbl, 2)
            Y = Tbl(i, mm)
            Tbl(i, mm) = Tbl(j, mm)
            Tbl(j, mm) = Y
        Next mm
        i = i + 1
        j = j - 1
    End If
Wend
If (L < j) Then Call QuickSort(Tbl, Col, L, j)
If (i < H) Then Call QuickSort(Tbl, Col, i, H)
End Sub

Et exemple d'appel

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Tri()
Dim Tb As Variant
 
Tb = Range("A1:C30000")
 
'tri sur la colonne 1
Call QuickSort(Tb, 1, 1, UBound(Tb, 1))
Range("E1:G30000") = Tb
 
'tri sur la colonne 3
Call QuickSort(Tb, 3, 1, UBound(Tb, 1))
Range("K1:M30000") = Tb
End Sub

[boboss123]

merci, cette algo est incroyable : en moins d'une seconde mon tableau est balayé alors qu'avec l'autre au bout de 3 minutes il n'a toujours pas terminé (j’arrête le programme).

Merci