XL 2013 les machistes (utilisateurs de Mac OS peuvent ils tester ceci

patricktoulon

XLDnaute Barbatruc
Bonjour à tous
@RyuAutodidacte m' a rappelé un lien vers un amis de l'autre monde concernant une classe pseudo dictionnaire pour MAC
malgré que j'apprécie beaucoup l'auteur (avec qui j'ai même collaboré sur l’accélérateur de requête entre autres ) ,je trouve que c'est un peu usine à gaz

j'ai donc fait les choses à ma façon
mais avant d'aller plus loin car des idées j'en ai plein ,si vous êtes un utilisateur sur MAC pouvez vous tester ce pseudo dictionnaire
sur Windows ça match il me faut confirmation sur MAC

Merci pour vos retours
 

Pièces jointes

  • classe dictionary pour Mac.xlsm
    18.3 KB · Affichages: 10
Dernière édition:

patricktoulon

XLDnaute Barbatruc
ben je l'ai testé le code @Dranreb (tri fusion) il est plus lent que le quicksort chez moi
pas de beaucoup 0.04 / 0.05 pareil que le tri fusion que j'ai récupéré et qui est hyper simple à comprendre
@Dranreb s'emploie a nous torpiller les boyeaux avec ses codes 🤣

si je fait un recueil pour le partager , c'est pour que tout les lecteurs comprennent ;)


allez met moi des beaux commentaires dans ton code
en expliquant ce que font les sub ou fonctions
 

RyuAutodidacte

XLDnaute Impliqué
Re
Ca se joue a pas grand chose en temps entre ShellMetzner (à gauche) et quickSort (à droite):
1698441442093.png

Edit : j'ai le refait en quicksort
1698441938483.png
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonsoir.
Je n'ai pas affirmé que mon tri fusion il était plus rapide à changer l'ordre des données elles même, seulement qu'il était plus rapide à établir la liste des numéros de lignes dans l'ordre où il faudra les parcourir qu'un QuickSort spécialement écrit pour faire de même.
 

patricktoulon

XLDnaute Barbatruc
re
@Dranreb voici le fusion
si tu a des points d'amélioration
VB:
'***************************************************************************************************************************
'**********************************************************************************
' __        _____  ___   .  ___         _____  ___             ___
'|__|  /\     |   |   |  | |     | /      |   |   | |   | |   |   | |\  |
'|    /__\    |   |---   | |     |/\      |   |   | |   | |   |   | | \ |
'|   /    \   |   |   \  | |___  |  \     |   |___| |___| |__ |___| |  \|
'
'***********************************************************************************
'RECEUIL DE M2THODE DE TRI D UN ARRAY
'Méthode 4
'                   Tri fusion (merge sort)

'Le tri fusion est un algorithme de la grande famille des algorithmes « diviser pour régner« .
'Il est légèrement plus complexe que les algorithmes précédents, mais son efficacité est redoutable !
'En particulier sur de grandes séquences de données.

'Cet algorithme de tri a une logique un peu plus complexe.

'On va commencer par diviser le tableau en deux éléments égaux.
'On va recommencer la même chose jusqu’à atteindre un seul élément par séparation.
'Ensuite, on va refusionner les éléments séparés de façon récursive en les triant à chaque niveau.

'C’est en comparant et permutant les éléments niveau par niveau qu’on construit un nouveau tableau trié

Dim Q&, Ch&

Sub Test_a_Grande_echelle_FUSION()
    Q = 0: Ch = 0: tm = Timer
  Cells(1, 3).Resize(10000).ClearContents
  t = Application.Transpose(Cells(1, 1).Resize(10000).Value)
    TriFusion t, 1, UBound(t)
    MsgBox Format(Timer - tm, "#0.00")
  Cells(1, 3).Resize(10000) = Application.Transpose(t)
End Sub


Sub TriFusion(tableau As Variant, IMin_Tableau As Long, IMax_Tableau As Long)
' Taille des sous-tableaux à fusionner
    Dim Taille As Long
    Dim IMin As Long
    Dim IMed As Long
    Dim IMax As Long
    ' Traitement pour chaque niveau de découpe, en partant de la plus fine
    Taille = 1
    While Taille <= (IMax_Tableau - IMin_Tableau + 1)
        IMin = IMin_Tableau
        IMed = IMin_Tableau + Taille - 1
        IMax = IMed + Taille
        ' Fusion de sous-tableaux 2 à 2
        While IMax <= IMax_Tableau
            Call FusionTableau(tableau, IMin, IMed, IMax)
            IMin = IMax + 1
            IMed = IMin + Taille - 1
            IMax = IMed + Taille
            Q = Q + 1
        Wend
        ' Fusion éventuelle du reliquat
        If IMax_Tableau > IMed Then
            ' La taille du reliquat est supérieure à celle d'un sous-tableau
            IMax = IMax_Tableau
            Call FusionTableau(tableau, IMin, IMed, IMax)
            Q = Q + 1
        End If
        Taille = Taille * 2
    Wend
End Sub

Sub FusionTableau(tableau As Variant, IMin As Long, IMed As Long, IMax As Long)
'************************************************************
' Fusion de deux sous-tableaux contigüs triés
' Procédure utilisée par l'algorithme de tri/fusion
' Tableau       Tableau où se trouvent les deux sous-tableaux
' IMin          Premier échelon du premier sous-tableau
' IMed          Dernier échelon du premier sous-tableau
' IMax          Dernier échelon du dernier sous-tableau
'************************************************************
    Dim I1&, I2&, I_T&, t&()
    ReDim t(IMax - IMin + 1)
    I1 = IMin
    I2 = IMed + 1
    I_T = 0
    ' Fusion des 2 sous-tableaux d'origine dans un nouveau tableau
    While (I1 <= IMed And I2 <= IMax)
        If tableau(I1) < tableau(I2) Then
            t(I_T) = tableau(I1)
            I1 = I1 + 1
        Else
            t(I_T) = tableau(I2)
            I2 = I2 + 1
        End If
        I_T = I_T + 1
        Q = Q + 1
    Wend
    While (I1 <= IMed)
        t(I_T) = tableau(I1)
        I1 = I1 + 1
        I_T = I_T + 1
        Q = Q + 1
    Wend
    While (I2 <= IMax)
        t(I_T) = tableau(I2)
        I2 = I2 + 1
        I_T = I_T + 1
        Q = Q + 1
    Wend
    ' Recopie dans le tableau d'origine
    I1 = IMin
    For I_T = 0 To (IMax - IMin)
        tableau(I1) = t(I_T)
        I1 = I1 + 1
        Q = Q + 1
        Ch = Ch + 1
    Next I_T
End Sub
 

patricktoulon

XLDnaute Barbatruc
re
tiens Laurent
VB:
'***************************************************************************************************************************
'**********************************************************************************
' __        _____  ___   .  ___         _____  ___             ___
'|__|  /\     |   |   |  | |     | /      |   |   | |   | |   |   | |\  |
'|    /__\    |   |---   | |     |/\      |   |   | |   | |   |   | | \ |
'|   /    \   |   |   \  | |___  |  \     |   |___| |___| |__ |___| |  \|
'
'***********************************************************************************
'RECEUIL DE M2THODE DE TRI D UN ARRAY
'Methode 3
'                               Tri rapide (quick sort)

'Le tri rapide (quicksort), ou tri pivot, fait aussi partie de la famille des algorithmes « diviser pour régner ».
'Lui aussi utilise donc de la récursivité et sa logique est un peu plus complexe. '
'Comme le tri fusion, il est cependant grandement utilisé dans les langages modernes.
'Son fonctionnement est centré autour du concept du pivot.
'On va choisir un élément dans le tableau et on va décréter que cet élément est le pivot pour une itération sur le tableau.
'Y’a différente façon de choisir un pivot, on ne va pas rentrer là-dedans, '
'aujourd’hui le pivot sera  l' élément du milieu du tableau.

'Une fois qu’on a ce pivot, on va faire 2 boucles du debut au milieu et du milieu à droite
'Toutes les valeurs plus basses que ce pivot vont à gauche de ce tableau.
'Toutes les valeurs plus grandes que ce pivot vont à droite.

'donc en sortie de ces deux sub boucles la plus petite valeur droite et la plus petite valeur gauche
'sont interverties si celle de droite est plus petite

'Et ensuite on va appeler de façon récursive La même fonction  avec  les argument tableau et D et G et gauche et droite
'les appels récursifs s 'arretent dès que G est plus petit  que Droite et que gauche  est plus petit que D
'grossomodo un apel récursif est en moyenne 10% plus rapide que une incrementation dans une boucle
'ce qui fait de cette méthode une des plus rapide

Dim Q&, Ch&

Sub Test_a_Grande_Echelle_QUICKSORT()
    Q = 0: Ch = 0: tim = Timer
    Cells(1, 3).Resize(10000).ClearContents
    t = Application.Transpose(Cells(1, 1).Resize(10000).Value)
    t = SortQuickSort(t, xlDescending) 'ou XlAscending
    MsgBox Format(Timer - tim, "#0.00") & " sec" & vbCrLf & Q & " TOURS DE BOUCLE SUR 3 DO/LOOP" & vbCrLf & Ch & " INTERVERTIONS"
    Cells(1, 3).Resize(10000) = Application.Transpose(t)
End Sub

Function SortQuickSort(tbl, Optional Sortmode As Long = 1, Optional Gauche = -1, Optional Droite = -1) ' Quick sort
    Dim ref, G&, D&, temp1, First, tim#
    If Droite = -1 And Gauche = -1 Then First = 1 Else First = 0
    Droite = IIf(Droite = -1, UBound(tbl), Droite)

    Gauche = IIf(Gauche = -1, LBound(tbl), Gauche)

    ref = tbl((Gauche + Droite) \ 2)    'le pivot( change de position au fur et a mesure)

    G = Gauche: D = Droite    'on dédouble les variable gauche et droite pour l'incrémentation dans les deux do/loop droite et gauche

    Do
        If Sortmode = 1 Then
            Do While tbl(G) < ref: G = G + 1:: Loop         'on comptabilise le passage
            Do While ref < tbl(D): D = D - 1: Q = Q + 1:: Loop  'on comptabilise le passage
        Else
            Do While tbl(G) > ref: G = G + 1:: Loop         'on comptabilise le passage
            Do While ref > tbl(D): D = D - 1: Q = Q + 1:: Loop 'on comptabilise le passage
        End If

        'intervertion des itemS tbl(G) à gauche du pivot et l'item tbl(d) à droite du pivot
        If G <= D Then
            temp1 = tbl(G): tbl(G) = tbl(D): tbl(D) = temp1
            G = G + 1: D = D - 1
            Ch = Ch + 1
        End If
    Loop While G <= D

    'si g ou gauche est plus petit on relance un appel  de la fonction (c'est la récursivité)
    If G < Droite Then x = SortQuickSort(tbl, Sortmode, G, Droite)

    If Gauche < D Then x = SortQuickSort(tbl, Sortmode, Gauche, D)

    'pour économiser un peu la charge memoire du return de la fonction on la charge dès que l'on revients à first
    'c'est à dire quand il n'y a plus d'appel récursifs
    If First = 1 Then SortQuickSort = tbl

End Function
j'ai remis l'option croissant ou decroissant dans la quick sort
 

RyuAutodidacte

XLDnaute Impliqué
Dernière édition:

RyuAutodidacte

XLDnaute Impliqué
Hello @laurent950
Bien l'astuce de ton code ci-dessous pour les chiffres entier ,… super rapide 👍 👍 👍
VB:
Sub RemplirTriCroissant()
    Dim Ta As Variant
    Dim Tb() As Variant
    Dim Tc() As Variant
    ReDim Tc(1 To 1)
    Dim lastRow As Long
    Dim i As Long
   
    ' Nettoie la colonne C où le tableau trié sera affiché
    Range(Cells(1, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3)).Clear
   
    ' Charger les données de la colonne Excel dans le tableau Ta
    Ta = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
   
    ' Mesure le temps de tri
    tt = Timer()
   
    ' Trouver la dernière ligne avec des données dans la colonne
    lastRow = UBound(Ta, 1)
   
    ' Trouver la plus petite valeur dans le tableau Ta
    minValeur = Application.WorksheetFunction.Min(Ta)
   
    ' Trouver la plus grande valeur dans le tableau Ta
    maxValeur = Application.WorksheetFunction.Max(Ta)
   
    ' Redimensionner Tb pour correspondre à la taille de Ta
    ReDim Tb(minValeur To maxValeur)
   
    ' Copier les données de Ta vers Tb
    For i = 1 To lastRow
        Tb(Ta(i, 1)) = Ta(i, 1)
    Next i
   
    ' Copier les données de Tb vers Tc (sans les vides)
    For i = 1 To lastRow
        If Tb(i) <> Empty Then
            Tc(UBound(Tc)) = Tb(i)
            ReDim Preserve Tc(1 To UBound(Tc) + 1)
        End If
    Next i
   
    MsgBox Timer() - tt
   
    ' Affiche le tableau trié en ordre croissant dans la colonne C
    Cells(1, 3).Resize(UBound(Tc), 1) = Application.WorksheetFunction.Transpose(Tc)
   
'    ' Afficher les données de Tb dans la fenêtre immédiate pour vérification (facultatif)
'    For i = LBound(Tc) To UBound(Tc)
'        Debug.Print Tc(i)
'    Next i
End Sub
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Hello Patrick ;)
Vraiment pas long le script pour marquer les speudo 👏👍
Edit : en fait tu utilise un Userform … ?

VB:
Function SortQuickSort(tbl, Optional Sortmode As Long = 1, Optional Gauche = -1, Optional Droite = -1)
Pourquoi => Optional Gauche = -1 et Optional Droite = -1 sont Optional et à -1 ?
re
ben c'est simple
c'est pour le départ pour les mettre a lbound ou ubound
sinon il faudrait connaitre le ubound dès le depart
et aussi savoir si le lbound est 0 ou 1 selon la base du tableau
il sont optional pour le depart
ensuite je les determine (1 seule fois !!!!!) au depart

apres c'est le code qui tourne qui fait le job et indique la valeur de gauche et droite
et en bas de function je les injecte dans les appels récursif

donc pour le 1er appel c'est -1 les autre la fonction fait toute seule

pour mon script c'est normal que ce ne soit pas long j'ai tout memorisé dans une feuille
le userform c'est pour les reconstruire
1698492639774.png
 

laurent950

XLDnaute Barbatruc
Bien l'astuce de ton code ci-dessous pour les chiffres entier ,… super rapide 👍 👍 👍
Merci @RyuAutodidacte
J'ai effacer comme Patrick n'avais pas répondu j'ai pensé que c'était pas bon.
J'ai aussi pensé à indexé l'alphabet à voir ?

J'ai modifié cette ligne
' Copier les données de Tb vers Tc (sans les vides)
For i = 1 To lastRow
par cette ligne
' Copier les données de Tb vers Tc (sans les vides)
For i = LBound(Tb) To UBound(Tb)

VB:
Sub RemplirTriCroissant()
    Dim Ta As Variant
    Dim Tb() As Variant
    Dim Tc() As Variant
    ReDim Tc(1 To 1)
    Dim lastRow As Long
    Dim i As Long
  
    ' Nettoie la colonne C où le tableau trié sera affiché
    Range(Cells(1, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3)).Clear
  
    ' Charger les données de la colonne Excel dans le tableau Ta
    Ta = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
  
    ' Mesure le temps de tri
    tt = Timer()
  
    ' Trouver la dernière ligne avec des données dans la colonne
    lastRow = UBound(Ta, 1)
  
    ' Trouver la plus petite valeur dans le tableau Ta
    minValeur = Application.WorksheetFunction.Min(Ta)
  
    ' Trouver la plus grande valeur dans le tableau Ta
    maxValeur = Application.WorksheetFunction.Max(Ta)
  
    ' Redimensionner Tb pour correspondre à la taille de Ta
    ReDim Tb(minValeur To maxValeur)
  
    ' Copier les données de Ta vers Tb
    For i = 1 To lastRow
        Tb(Ta(i, 1)) = Ta(i, 1)
    Next i
  
    ' Copier les données de Tb vers Tc (sans les vides)
    For i = LBound(Tb) To UBound(Tb)
        If Tb(i) <> Empty Then
            Tc(UBound(Tc)) = Tb(i)
            ReDim Preserve Tc(1 To UBound(Tc) + 1)
        End If
    Next i
    Cells(1, 5) = Timer() - tt
    'MsgBox Timer() - tt
  
    ' Affiche le tableau trié en ordre croissant dans la colonne C
    Cells(1, 3).Resize(UBound(Tc), 1) = Application.WorksheetFunction.Transpose(Tc)
  
'    ' Afficher les données de Tb dans la fenêtre immédiate pour vérification (facultatif)
'    For i = LBound(Tc) To UBound(Tc)
'        Debug.Print Tc(i)
'    Next i
End Sub
 
Dernière édition:

RyuAutodidacte

XLDnaute Impliqué
Re
oui sur des chiffres entier c'est Ok par contre avec décimal ou alphabet c'est pas la même
Merci @RyuAutodidacte
J'ai effacer comme Patrick n'avais pas répondu j'ai pensé que c'était pas bon.
J'ai aussi pensé à indexé l'alphabet à voir ?

J'ai modifié cette ligne
' Copier les données de Tb vers Tc (sans les vides)
For i = 1 To lastRow
par cette ligne
' Copier les données de Tb vers Tc (sans les vides)
For i = LBound(Tb) To UBound(Tb)

VB:
Sub RemplirTriCroissant()
    Dim Ta As Variant
    Dim Tb() As Variant
    Dim Tc() As Variant
    ReDim Tc(1 To 1)
    Dim lastRow As Long
    Dim i As Long
 
    ' Nettoie la colonne C où le tableau trié sera affiché
    Range(Cells(1, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3)).Clear
 
    ' Charger les données de la colonne Excel dans le tableau Ta
    Ta = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
 
    ' Mesure le temps de tri
    tt = Timer()
 
    ' Trouver la dernière ligne avec des données dans la colonne
    lastRow = UBound(Ta, 1)
 
    ' Trouver la plus petite valeur dans le tableau Ta
    minValeur = Application.WorksheetFunction.Min(Ta)
 
    ' Trouver la plus grande valeur dans le tableau Ta
    maxValeur = Application.WorksheetFunction.Max(Ta)
 
    ' Redimensionner Tb pour correspondre à la taille de Ta
    ReDim Tb(minValeur To maxValeur)
 
    ' Copier les données de Ta vers Tb
    For i = 1 To lastRow
        Tb(Ta(i, 1)) = Ta(i, 1)
    Next i
 
    ' Copier les données de Tb vers Tc (sans les vides)
    For i = LBound(Tb) To UBound(Tb)
        If Tb(i) <> Empty Then
            Tc(UBound(Tc)) = Tb(i)
            ReDim Preserve Tc(1 To UBound(Tc) + 1)
        End If
    Next i
    Cells(1, 5) = Timer() - tt
    'MsgBox Timer() - tt
 
    ' Affiche le tableau trié en ordre croissant dans la colonne C
    Cells(1, 3).Resize(UBound(Tc), 1) = Application.WorksheetFunction.Transpose(Tc)
 
'    ' Afficher les données de Tb dans la fenêtre immédiate pour vérification (facultatif)
'    For i = LBound(Tc) To UBound(Tc)
'        Debug.Print Tc(i)
'    Next i
End Sub


Pour répondre à ta question en MP sur la rapidité du TriShellMetzner sur 60 000 :
VB:
Sub testTSM()
    Range(Cells(1, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3)).Clear
    Ta = Application.Transpose(Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)))
    tt = Timer()
    Ta = TriShellMetzner(Ta, True)
    MsgBox Timer() - tt
    Cells(1, 3).Resize(UBound(Ta)) = Application.Transpose(Ta)
End Sub

Function TriShellMetzner(a, ordre)
    Dim inc As Long, i As Long, j As Long, N As Long
    Dim inv As Boolean, tmp As Variant
    N = UBound(a)
    inc = N \ 2
    Do While inc <> 0
      For i = 1 To N - inc
        j = i
        inv = True
        Do While j > 0 And inv
          inv = False
          If ordre Then
            If a(j) > a(j + inc) Then tmp = a(j): a(j) = a(j + inc): a(j + inc) = tmp: inv = True: j = j - inc
          Else
            If a(j) < a(j + inc) Then tmp = a(j): a(j) = a(j + inc): a(j + inc) = tmp: inv = True:   j = j - inc
          End If
        Loop
      Next i
      inc = inc \ 2
    Loop
    TriShellMetzner = a
End Function

1698497815305.png

Chiffres sans doublons que j'ai généré avec le code que je viens d'écrire :
VB:
Sub RandomNumbersUnique()
Dim C As New Collection, N, lowerbound As Integer, upperbound As Long
    lowerbound = 1
    upperbound = 60000
    ReDim N(lowerbound To upperbound, 1 To 1)
    On Error Resume Next
    For i = lowerbound To upperbound
        RandomNumber = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
        C.Add RandomNumber, CStr(RandomNumber)
        If Err Then
            Do While Err
                Err.Clear
                RandomNumber = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
                C.Add RandomNumber, CStr(RandomNumber)
            Loop
        End If
        N(i, 1) = RandomNumber
    Next
    Application.ScreenUpdating = False
    Cells(1).Resize(upperbound).Value = N
    Application.ScreenUpdating = True
End Sub
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Bonjour Laurent
indexer les lettres de l'alphabet
l'astuce à 2 euros comme ça vite fait à l’arrache 🤣
VB:
Sub test()
    x = Split("I.F.G.Z.H.V.J.K.L.M.N.D.B.O.E.P.Q.R.S.C.T.U.A.W.X.Y", ".")
    x = ALPHA_INDEX(x)
    MsgBox Join(x, ",")
End Sub


Function ALPHA_INDEX(arr As Variant)
    ReDim t(LBound(arr) To UBound(arr))
    bas = CLng(LBound(arr) = 0)
    For i = LBound(arr) To UBound(arr)
        Index = Range(arr(i) & "1").Column
        t(Index + bas) = arr(i)
    Next
    ALPHA_INDEX = t
End Function
 

Membres actuellement en ligne

Statistiques des forums

Discussions
314 017
Messages
2 104 583
Membres
109 084
dernier inscrit
mizab