'******************************************************************************************************************************************************
' __ _ _ _ _ _ _ _ _______ ___ ___ _ ___ _ ____ _______ ____
' // \\ // // // // /\\ // // // // \\ // || // // || /\\ // // //
' //__// \\// // // //__\ // // // // // // || // // || //__\ // // //__
' // \\ // // // // \\ // // // // // // // // // // // \\ // // //
'// // // //__// // ////__// // \\__// //___// // //___// // ////___ // //___
'******************************************************************************************************************************************************
'méthode 6
'Auteur: Ryuautodidacte et patricktoulon sur ExcelDownloads
'version1 1.0
'réécrite en une seule fonction par patricktoulon
'insertion des code sortinsertbubble intra code
' cette fonction reside sur le fait d'utiliser un object collection qui va contenir dans les valeur un array de chaine similaire
'ou commencant par les meme caractères
'ensuite on va trier chaque sub array avec la méthode sortinsertbubble de patricktoulon
'ensuite on va refaire une passe sortinserbubble sur le TAg général (qui contioent des sub arrary)
'et le trier par la valeur du premier item de chaque array
'et pour finir on recompile les sub array dans un seul tableau (celui d'origine )
'
'vous l'avez compris on est dans la catégorie de fonction de tri dite "Diviser pour mieux reigner"
'en effet les boucles sont moins longues et plus rapide a trier
'mis apart l'object collection on est tres proche de la méthode fusion coisée avec l'insertion
'*****************************************************************************************************
Option Base 1
Dim Q
Dim ch
Sub test()
Dim tb, tim#
Q = 0: ch = 0
tb = Cells(1).CurrentRegion.Value
Cells(1, 3).Resize(UBound(tb)).ClearContents
tim = Timer
tb = SortRyuPatKey(tb)
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(tb)) = (tb)
End Sub
Function SortRyuPatKey(tb)
Dim TA(), SortColl As New Collection, GetTA, Tmps!, L, a&, b&, x&, ref, SubTB, SubTBA
For Each t In tb
ReDim NewTB(1 To 1)
L = Mid(t, 1, Len(t) - 1): S = Len(t): cle = L & "|" & S
On Error Resume Next
SortColl.Add IIf(SortColl.Count = 0, 1, SortColl.Count + 1), cle
If Err Then
GetTA = TA(SortColl(cle)): ReDim Preserve GetTA(1 To UBound(GetTA) + 1): GetTA(UBound(GetTA)) = t: TA(SortColl(cle)) = GetTA
Else
ReDim Preserve TA(1 To SortColl.Count): TA(SortColl(cle)) = Array(t)
End If
Next
'tri SortInsertBubble des sub array dans l'array TA
For i = 1 To UBound(TA)
SubTB = TA(i)
For a = LBound(SubTB) To UBound(SubTB)
ref = SubTB(a)
x = a
For b = a + 1 To (UBound(SubTB))
Q = Q + 1
If ref > SubTB(b) Then ref = SubTB(b): x = b:
Next b
If x <> a Then TP = SubTB(a): SubTB(a) = SubTB(x): SubTB(x) = TP: ch = ch + 1
Next a
TA(i) = SubTB
Q = Q + 1
Next
' second tri sortinsertbubble sur le TA genéral
' le tri va se faire sur le premier item de chaque array dans subTBA
SubTBA = TA
For a = LBound(SubTBA) To UBound(SubTBA)
ref = SubTBA(a)(1)
x = a
For b = a + 1 To (UBound(SubTBA))
Q = Q + 1
If ref > SubTBA(b)(1) Then ref = SubTBA(b)(1): x = b:
Next b
If x <> a Then TP = SubTBA(a): SubTBA(a) = SubTBA(x): SubTBA(x) = TP: ch = ch + 1
Next a
TA = SubTBA
ReDim tb(1 To 1)
n = 0
For Each arr In TA
Q = Q + 1
ReDim Preserve tb(1 To n + UBound(arr))
For i = 1 To UBound(arr)
Q = Q + 1
tb(i + n) = arr(i)
Next
n = UBound(tb)
Next
SortRyuPatKey = Application.Transpose(tb)
End Function
tu ne comptes pas le tri de Laurent que j'avais modifié (uniquement pour les chiffres entier) … ? plus rapide que quicksort …pour le moment tu es la plus rapide des plus lentes sur 10 000 et 100 000 items
par contre en terme d'uc de memoire et procc tu est de loin la plus lourde
classement de la plus lente à la plus rapide
bubble 8 secondes pour 10 000 items
insertion 7 secondes pour 10 000 items
insertionbubble hybride 2.80/3.50 secondes pour 10 000 items
SortRyuPatKey <--ici 0.55/0.70 secondes pour 10 000 items
les plus rapides
fusion 0.05/0.06. secondes pour 10 000 items
shellmetzner 0.04 /0.06 secondes pour 10 000 items
quiksort patrick 2dim 0.03/0.04 secondes pour 10 000 items
LA PLUS RAPIDE!!!
quicksortpatrick 1 dim execo avec quicksort laurent 0.0.18/0.03 sur 10 000 items
quicksort Laurent a tendence a être un peu devant (Bravo Laurent)
classement de la plus lourde a la moins lourde
SortRyuPatKey et de loin( a peu près 800% de plus que la insertion )
insertion
insertionbubble
bubble
quicksort laurent
shellmetzner
fusion
quicksortpatrick2 dim
quicksort patrick 1dim
'******************************************************************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'******************************************************************************************************************************************************
'RECEUIL DE M2THODE DE TRI D UN ARRAY
'Méthode 2.1 patricktoulon
' HYbridemixe de ( Bubble et Insertion)
' dans cette version je mixe la méthode bubble et la méthode insertion
'les items ne sont déplacé qu'une fois (si nécessaire)
'la premiere boucle est la répéteuse et donne le pivot(la référence)
'la seconde tourne a moitié du restant du nombre d'item
'cherche le plus petit de index boucle1 a moitié restant et du ubound jusque a index B
'en sortie de 2d boucle je fait l'interversion
Dim q&
Dim ch&
Sub Test3InsertBuble3()
Dim T, tim#
ch = 0: q = 0
T = Application.Transpose([A1:A10000].Value)
[j8:l8] = ""
tim = Timer
T = sortInsertBubble3(T)
[j8:l8] = Array(q, ch, Format(Timer - tim, "#0.00 ""sec"""))
Cells(1, 3).Resize(10000).Value = Application.Transpose(T)
End Sub
Function sortInsertBubble3(T)
Dim A&, B&, C&, x&, ref
For A = LBound(T) To UBound(T)
ref = T(A)
x = A
C = UBound(T)
w = (UBound(T) - A) / 2
'Dans une seule boucle B avance de A+1 vers le ubound et C recule du ubound vers B
' quand les deux se rencontrent on arrete de boucler
' on fait donc la moitié du nombre de tours de la hybride 1
For B = A + 1 To UBound(T) - w
q = q + 1
If ref > T(B) Then ref = T(B): x = B:
If ref > T(C) Then ref = T(C): x = C:
C = C - 1
Next
If T(x) < T(A) Then TP = T(A): T(A) = T(x): T(x) = TP: ch = ch + 1
Next A
sortInsertBubble3 = T
End Function
Option Base 1
Dim Q&
Dim ch&
Sub testQSort()
Dim TB, TA(), SortColl As New Collection, GetTA, tim!, Mn
Cells(1, 3).Resize(10000).ClearContents
Q = 0: ch = 0: tim = Timer
n = 1: ReDim temp(1 To 1)
TB = Cells(1).CurrentRegion.Value
For Each t In TB
ReDim NewTB(1 To 1)
L = Mid(t, 1, Len(t) - 1): S = Len(t): cle = L & S
On Error Resume Next
SortColl.Add IIf(SortColl.Count = 0, 1, SortColl.Count + 1), cle
If Err Then
GetTA = TA(SortColl(cle)): ReDim Preserve GetTA(1 To UBound(GetTA) + 1): GetTA(UBound(GetTA)) = t: TA(SortColl(cle)) = GetTA
Else
ReDim Preserve TA(1 To SortColl.Count): TA(SortColl(cle)) = Array(t): ReDim Preserve temp(1 To n): temp(n) = CLng(cle)
n = UBound(temp) + 1
End If
Next
ReDim TB(1 To UBound(temp))
For i = 1 To UBound(temp)
Mn = Application.Min(temp)
Mn = CStr(Mn)
TB(i) = TA(SortColl(Mn)): temp(SortColl(Mn)) = 1E+37
Next
For i = 1 To UBound(TB): TB(i) = SortBubble(TB(i)): Q = Q + 1:: Next
ReDim TA(1 To 1)
n = 0
For Each arr In TB
Q = Q + 1
ReDim Preserve TA(1 To n + UBound(arr))
For i = 1 To UBound(arr)
Q = Q + 1
TA(i + n) = arr(i)
Next
n = UBound(TA)
Next
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(TA)) = Application.Transpose(TA)
End Sub
Function SortBubble(t) 'fonction Tri à bulle classique
Dim temp, i&, a&
For i = LBound(t) To UBound(t) - 1
For a = i To UBound(t)
Q = Q + 1
If t(i) > t(a) Then temp = t(i): t(i) = t(a): t(a) = temp: ch = ch + 1
Next
Next
SortBubble = t
End Function
Option Base 1
Dim Q&, ch&, P&
'Tri par insertion (Insertion sort)
Sub testQSort()
Dim TB, TA(), SortColl As New Collection, GetTA, tim!, Mn
Cells(1, 3).Resize(10000).ClearContents
Q = 0: ch = 0: tim = Timer
n = 1: ReDim temp(1 To 1)
TB = Cells(1).CurrentRegion.Value
For Each t In TB
ReDim NewTB(1 To 1)
L = Mid(t, 1, Len(t) - 1): S = Len(t): cle = L & S
On Error Resume Next
SortColl.Add IIf(SortColl.Count = 0, 1, SortColl.Count + 1), cle
If Err Then
GetTA = TA(SortColl(cle)): ReDim Preserve GetTA(1 To UBound(GetTA) + 1): GetTA(UBound(GetTA)) = t: TA(SortColl(cle)) = GetTA
Else
ReDim Preserve TA(1 To SortColl.Count): TA(SortColl(cle)) = Array(t): ReDim Preserve temp(1 To n): temp(n) = CLng(cle)
n = UBound(temp) + 1
End If
Next
ReDim TB(1 To UBound(temp))
For i = 1 To UBound(temp)
Mn = Application.Min(temp)
Mn = CStr(Mn)
TB(i) = TA(SortColl(Mn)): temp(SortColl(Mn)) = 1E+37
Next
For i = 1 To UBound(TB): TB(i) = SortInsertion1(TB(i)): Q = Q + 1:: Next
ReDim TA(1 To 1)
n = 0
For Each arr In TB
Q = Q + 1
ReDim Preserve TA(1 To n + UBound(arr))
For i = 1 To UBound(arr)
Q = Q + 1
TA(i + n) = arr(i)
Next
n = UBound(TA)
Next
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(TA)) = Application.Transpose(TA)
End Sub
Function SortInsertion1(t)
Dim temp, i&, a&
For i = LBound(t) + 1 To UBound(t)
For a = LBound(t) To i - 1
If t(i) < t(a) Then TP = t(i): t(i) = t(a): t(a) = TP: ch = ch + 1
Q = Q + 1
Next
Next
SortInsertion1 = t
End Function
Option Base 1
Dim Q
Dim ch
Sub testQSort()
Dim TB, TA(), SortColl As New Collection, GetTA, tim!, Mn
Cells(1, 3).Resize(10000).ClearContents
Q = 0: ch = 0: tim = Timer
n = 1: ReDim temp(1 To 1)
TB = Cells(1).CurrentRegion.Value
For Each t In TB
ReDim NewTB(1 To 1)
L = Mid(t, 1, Len(t) - 1): S = Len(t): cle = L & S
On Error Resume Next
SortColl.Add IIf(SortColl.Count = 0, 1, SortColl.Count + 1), cle
If Err Then
GetTA = TA(SortColl(cle)): ReDim Preserve GetTA(1 To UBound(GetTA) + 1): GetTA(UBound(GetTA)) = t: TA(SortColl(cle)) = GetTA
Else
ReDim Preserve TA(1 To SortColl.Count): TA(SortColl(cle)) = Array(t): ReDim Preserve temp(1 To n): temp(n) = CLng(cle)
n = UBound(temp) + 1
End If
Next
ReDim TB(1 To UBound(temp))
For i = 1 To UBound(temp)
Mn = Application.Min(temp)
Mn = CStr(Mn)
TB(i) = TA(SortColl(Mn)): temp(SortColl(Mn)) = 1E+37
Next
For i = 1 To UBound(TB): TB(i) = sortInsertBubble(TB(i)): Q = Q + 1:: Next
ReDim TA(1 To 1)
n = 0
For Each arr In TB
Q = Q + 1
ReDim Preserve TA(1 To n + UBound(arr))
For i = 1 To UBound(arr)
Q = Q + 1
TA(i + n) = arr(i)
Next
n = UBound(TA)
Next
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(TA)) = Application.Transpose(TA)
End Sub
Function sortInsertBubble(t)
Dim a&, b&, C&, x&, D&, Z&, ref, refD
For a = LBound(t) To UBound(t)
ref = t(a): refD = t(a)
x = a
For b = a + 1 To (UBound(t))
Q = Q + 1
If ref > t(b) Then ref = t(b): x = b:
Next b
If x <> a Then TP = t(a): t(a) = t(x): t(x) = TP: ch = ch + 1
Next a
sortInsertBubble = t
End Function
'******************************************************************************************************************************************************
' __ _ _ _ _ _ _ _ _______ ___ ___ _ ___ _ ____ _______ ____
' // \\ // // // // /\\ // // // // \\ // || // // || /\\ // // //
' //__// \\// // // //__\ // // // // // // || // // || //__\ // // //__
' // \\ // // // // \\ // // // // // // // // // // // \\ // // //
'// // // //__// // ////__// // \\__// //___// // //___// // ////___ // //___
'******************************************************************************************************************************************************
'méthode 6
'Auteur: Ryuautodidacte et patricktoulon sur ExcelDownloads
'version1 1.0
'réécrite en une seule fonction par patricktoulon
'insertion des code sortinsertbubble intra code
' cette fonction reside sur le fait d'utiliser un object collection qui va contenir dans les valeur un array de chaine similaire
'ou commencant par les meme caractères
'ensuite on va trier chaque sub array avec la méthode sortinsertbubble de patricktoulon
'ensuite on va refaire une passe sortinserbubble sur le TAg général (qui contioent des sub arrary)
'et le trier par la valeur du premier item de chaque array
'et pour finir on recompile les sub array dans un seul tableau (celui d'origine )
'
'vous l'avez compris on est dans la catégorie de fonction de tri dite "Diviser pour mieux reigner"
'en effet les boucles sont moins longues et plus rapide a trier
'mis apart l'object collection on est tres proche de la méthode fusion coisée avec l'insertion
'*****************************************************************************************************
Option Base 1
Dim Q
Dim ch
Sub test()
Dim TB, tim#
Q = 0: ch = 0
TB = Cells(1).CurrentRegion.Value
Cells(1, 3).Resize(UBound(TB)).ClearContents
tim = Timer
TB = SortRyuPatKey(TB)
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(TB)) = (TB)
End Sub
Function SortRyuPatKey(TB)
Dim TA(), SortColl As New Collection, GetTA, Tmps!, L, a&, b&, x&, ref, SubTB, SubTBA, D&, W&
For Each t In TB
ReDim NewTB(1 To 1)
L = Mid(t, 1, Len(t) - 1): S = Len(t): cle = L & "|" & S
On Error Resume Next
SortColl.Add IIf(SortColl.Count = 0, 1, SortColl.Count + 1), cle
If Err Then
GetTA = TA(SortColl(cle)): ReDim Preserve GetTA(1 To UBound(GetTA) + 1): GetTA(UBound(GetTA)) = t: TA(SortColl(cle)) = GetTA
Else
ReDim Preserve TA(1 To SortColl.Count): TA(SortColl(cle)) = Array(t)
End If
Next
'tri SortInsertBubbleGD des sub array dans l'array TA
For i = 1 To UBound(TA)
SubTB = TA(i)
For a = LBound(SubTB) To UBound(SubTB)
ref = SubTB(a)
x = a
D = UBound(TA)
W = (UBound(TA) - a) / 2
For b = a + 1 To (UBound(SubTB) - W)
Q = Q + 1
If ref > SubTB(b) Then ref = SubTB(b): x = b:
If ref > SubTB(D) Then ref = SubTB(D): x = D:
D = D - 1
Next b
If x <> a Then TP = SubTB(a): SubTB(a) = SubTB(x): SubTB(x) = TP: ch = ch + 1
Next a
TA(i) = SubTB
Q = Q + 1
Next
' second tri sortinsertbubble sur le TA genéral
' le tri va se faire sur le premier item de chaque array dans subTBA
SubTBA = TA
For a = LBound(SubTBA) To UBound(SubTBA)
ref = SubTBA(a)(1)
x = a
For b = a + 1 To (UBound(SubTBA))
Q = Q + 1
If ref > SubTBA(b)(1) Then ref = SubTBA(b)(1): x = b:
Next b
If x <> a Then TP = SubTBA(a): SubTBA(a) = SubTBA(x): SubTBA(x) = TP: ch = ch + 1
Next a
TA = SubTBA
ReDim TB(1 To 1)
n = 0
For Each arr In TA
Q = Q + 1
ReDim Preserve TB(1 To n + UBound(arr))
For i = 1 To UBound(arr)
Q = Q + 1
TB(i + n) = arr(i)
Next
n = UBound(TB)
Next
SortRyuPatKey = Application.Transpose(TB)
End Function