Option Base 1
Dim Q
Dim ch
Sub testQSort()
Dim TB, TA(), SortColl As New Collection, GetTA, Tmps!
Cells(1, 3).Resize(10000).ClearContents
Q = 0: ch = 0: tim = Timer
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)
End If
Next
For i = 1 To UBound(TA): TA(i) = sortInsertBubble(TA(i)): Q = Q + 1:: Next
TA = sortInsertBubbleTB(TA)
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
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(TB)) = Application.Transpose(TB)
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
Function sortInsertBubbleTB(t)
Dim a&, b&, C&, x&, D&, Z&, ref, refD
For a = LBound(t) To UBound(t)
ref = t(a)(1): refD = t(a)(1)
x = a
For b = a + 1 To (UBound(t))
Q = Q + 1
If ref > t(b)(1) Then ref = t(b)(1): x = b:
Next b
If x <> a Then TP = t(a): t(a) = t(x): t(x) = TP: ch = ch + 1
Next a
sortInsertBubbleTB = t
End Function
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
Re j'ai l'impression que l'on a pas le même code, c'est celui-ci :donc pour moi tes 0.54 sont impossible avec le code que tu a fourni en post329
démonstration de ton code tel quel testé ssur 10 000 items
Option Base 1
Dim Q
Dim ch
Sub testQSort()
Dim TB, TA(), SortColl As New Collection, GetTA, Tmps!
Cells(1, 3).Resize(10000).ClearContents
Q = 0: ch = 0: tim = Timer
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)
End If
Next
For i = 1 To UBound(TA): TA(i) = sortInsertBubble(TA(i)): Q = Q + 1:: Next
TA = sortInsertBubbleTB(TA)
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
MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE" & vbCrLf & ch & " INTERVERTIONS"
Cells(1, 3).Resize(UBound(TB)) = Application.Transpose(TB)
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
Function sortInsertBubbleTB(t)
Dim a&, b&, C&, x&, D&, Z&, ref, refD
For a = LBound(t) To UBound(t)
ref = t(a)(1): refD = t(a)(1)
x = a
For b = a + 1 To (UBound(t))
Q = Q + 1
If ref > t(b)(1) Then ref = t(b)(1): x = b:
Next b
If x <> a Then TP = t(a): t(a) = t(x): t(x) = TP: ch = ch + 1
Next a
sortInsertBubbleTB = t
End Function
Pourtant si regardes (ou il y a un bug alors … ??) :tu a du le modifier entre temps mais pas posté
ben je ten ai parlé de mon pré-tri mais tu n y a pa cruon est donc dans un hybride fusionInsertionbubbleByKey
j'aurais jamais cru aussi rapide si je n'avais pas essayé
c'est comme ça que je veux que tu travaille tout le temps