'******************************************************************************************************************************************************
' __ _ _ _ _ _ _ _ _______ ___ ___ _ ___ _ ____ _______ ____
' // \\ // // // // /\\ // // // // \\ // || // // || /\\ // // //
' //__// \\// // // //__\ // // // // // // || // // || //__\ // // //__
' // \\ // // // // \\ // // // // // // // // // // // \\ // // //
'// // // //__// // ////__// // \\__// //___// // //___// // ////___ // //___
'******************************************************************************************************************************************************
'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
