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:

RyuAutodidacte

XLDnaute Impliqué
@patricktoulon
re
keyItemreverse est a utiliser avec parsimonie
il est évident que si tu a des doublons dans les valeurs (les items) ça n'a plus la teneur d'un dico après reverse
cependant pour le tri par les valeurs et non les clés ,
il peut être intéressant de pourvoir faire un reverse /tri/reverse
de même que si c'est un exercice sans doublons d'items on peut faire un reverse

attention le reverse ne peut être utilisé que pour des valeurs numériques ou texte
si tu a des objects dans tes items c'est mort

d’ailleurs il faudrait que je le bloque en cas d'object
pour ma part le reverse je vais pas le mettre car il n y aura que des cas extrêmement minime
cependant pour le tri par les valeurs et non les clés ,
il peut être intéressant de pourvoir faire un reverse /tri/reverse
Nul besoin de reverse pour ma part si j'ai besoin de trier par les clé
voila si un seul object range ou autres est entré dans les items le reverse est bloqué
j'ai mis un 👍 sans regarder car c'est ce qu'il faut faire quoiqu'il en soit (et j'ai pas fini mon code ;) )

@Dranreb
La base, je dirais, c'est ma description. Pour ce qui est des codes, la version pour une seule colonne fait partie de mon module de service MSujetCBx :
VB:
Sub IndexerFus1Col(TIdx() As Long, TDon(), _
   Optional ByVal Croissant As Boolean = True, Optional ByVal LMax As Long)
   Dim NR As Long, ÀFusionner As New Collection, _
       L1 As Long, TFus1() As Long, N1 As Long, Arg1, _
       L2 As Long, TFus2() As Long, N2 As Long, Arg2
   If LMax <= 0 Then LMax = UBound(TDon, 1)
   ReDim TIdx(1 To &HFFF&)
   NR = 1: TIdx(1) = 1: L1 = 1: Arg1 = TDon(1, 1)
   If VarType(Arg1) = vbString Then If Arg1 = "" Then Arg1 = Empty: TDon(1, 1) = Empty
   For L2 = 2 To LMax: Arg2 = TDon(L2, 1)
      If VarType(Arg2) = vbString Then If Arg2 = "" Then Arg2 = Empty: TDon(L2, 1) = Empty
      If DansLOrdre(Arg1, Arg2, Croissant, L1 < L2) Then
         NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
         TIdx(NR) = L2: L1 = L2: Arg1 = Arg2
      ElseIf NR < 20 Then
         For N1 = 1 To NR - 1: L1 = TIdx(N1): If DansLOrdre(Arg2, TDon(L1, 1), Croissant, L1 > L2) Then Exit For
            Next N1
         NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
         For N2 = NR To N1 + 1 Step -1: TIdx(N2) = TIdx(N2 - 1): Next N2
         TIdx(N1) = L2: L1 = TIdx(NR): Arg1 = TDon(L1, 1)
      Else: ReDim Preserve TIdx(1 To NR): ÀFusionner.Add TIdx: NR = 1
         TIdx(1) = L2: L1 = L2: Arg1 = Arg2: End If
      Next L2
   ReDim Preserve TIdx(1 To NR)
   Do While ÀFusionner.Count > 0
      ÀFusionner.Add TIdx
      TFus1 = ÀFusionner(1): N1 = 1: ÀFusionner.Remove 1
      TFus2 = ÀFusionner(1): N2 = 1: ÀFusionner.Remove 1
      ReDim TIdx(1 To UBound(TFus1) + UBound(TFus2))
      L1 = TFus1(1): Arg1 = TDon(L1, 1)
      L2 = TFus2(1): Arg2 = TDon(L2, 1)
      NR = 0: Do: NR = NR + 1
         If DansLOrdre(Arg1, Arg2, Croissant, L1 < L2) Then
               TIdx(NR) = L1: N1 = N1 + 1: If N1 <= UBound(TFus1) Then L1 = TFus1(N1): Arg1 = TDon(L1, 1) Else GoTo Fin2
         Else: TIdx(NR) = L2: N2 = N2 + 1: If N2 <= UBound(TFus2) Then L2 = TFus2(N2): Arg2 = TDon(L2, 1) Else Exit Do
            End If
         Loop
      Do: NR = NR + 1: TIdx(NR) = TFus1(N1): N1 = N1 + 1: Loop Until N1 > UBound(TFus1): GoTo FusS
Fin2: Do: NR = NR + 1: TIdx(NR) = TFus2(N2): N2 = N2 + 1: Loop Until N2 > UBound(TFus2)
FusS: Loop
   End Sub
Private Function DansLOrdre(ByVal Val1, ByVal Val2, ByVal Croissant As Boolean, ByVal ParDéf As Boolean) As Boolean
   Dim Typ1 As VbVarType, Typ2 As VbVarType, Sens As Integer, Comp As Integer
   Sens = 2 * -Croissant - 1
   Typ1 = VarType(Val1): Typ2 = VarType(Val2)
   Select Case Typ2
      Case Is <> Typ1: Comp = Sgn(Typ2 - Typ1)
      Case vbString: Comp = StrComp(Val2, Val1) * Sens
      Case vbError: Comp = Sgn(CLng(Val2) - CLng(Val1)) * Sens
      Case vbEmpty: Comp = 0
      Case Else: Comp = Sgn(Val2 - Val1) * Sens: End Select
   If Comp = 0 Then DansLOrdre = ParDéf Else DansLOrdre = Comp > 0
   End Function
La version pour plusieurs colonnes fait partie de mon module MGigogne :
VB:
Sub IndexerParFusions(TIdx() As Long, TDon(), ParamArray ColOrd() As Variant)
   Dim NR As Long, NE As Long, Comp As Integer, ÀFusionner As New Collection, _
       L1 As Long, TFus1() As Long, N1 As Long, _
       L2 As Long, TFus2() As Long, N2 As Long
   If UBound(ColOrd) >= LBound(ColOrd) Then InterpréterParam ColOrd, UBound(TDon, 2), "IndexerParFusion"
   ReDim TIdx(1 To &HFFF&)
   NR = 1
   If Préfiltré Then
      L1 = TLgnFlt(1): TIdx(1) = L1
      For NE = 2 To UBound(TLgnFlt): L2 = TLgnFlt(NE): GoSub Comparer
         If Comp = 1 Then
         NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
         TIdx(NR) = L2: L1 = L2
      ElseIf NR = 1 Then
         NR = 2: If UBound(TIdx) < 2 Then ReDim Preserve TIdx(1 To &HFFF&)
         TIdx(1) = L2: TIdx(2) = L1
      Else
         ReDim Preserve TIdx(1 To NR): ÀFusionner.Add TIdx: NR = 1
         TIdx(1) = L2: L1 = L2: End If: Next NE
   Else
      If Tronquer Then
         If LMax > UBound(TDon, 1) Then LMax = UBound(TDon, 1)
      Else: LMax = UBound(TDon, 1): End If
      L1 = LBound(TDon, 1): TIdx(1) = L1
      For L2 = L1 + 1 To LMax: GoSub Comparer
         If Comp = 1 Then
            NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
            TIdx(NR) = L2: L1 = L2
         ElseIf NR < 20 Then
            For N1 = 1 To NR - 1: L1 = TIdx(N1): GoSub Comparer: If Comp < 0 Then Exit For
               Next N1
            NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
            For N2 = NR To N1 + 1 Step -1: TIdx(N2) = TIdx(N2 - 1)
               Next N2
            TIdx(N1) = L2: L1 = TIdx(NR)
         Else
            ReDim Preserve TIdx(1 To NR): ÀFusionner.Add TIdx: NR = 1
            TIdx(1) = L2: L1 = L2: End If: Next L2
      End If
   ReDim Preserve TIdx(1 To NR)
   Do While ÀFusionner.Count > 0
      ÀFusionner.Add TIdx
      TFus1 = ÀFusionner(1): N1 = 1: ÀFusionner.Remove 1
      TFus2 = ÀFusionner(1): N2 = 1: ÀFusionner.Remove 1
      ReDim TIdx(1 To UBound(TFus1) + UBound(TFus2))
      NR = 0: L1 = TFus1(1): L2 = TFus2(1)
      Do: NR = NR + 1: GoSub Comparer
         If Comp = 1 Then
               TIdx(NR) = L1: N1 = N1 + 1: If N1 <= UBound(TFus1) Then L1 = TFus1(N1) Else GoTo Fin2
         Else: TIdx(NR) = L2: N2 = N2 + 1: If N2 <= UBound(TFus2) Then L2 = TFus2(N2) Else Exit Do
            End If
         Loop
      Do: NR = NR + 1: TIdx(NR) = TFus1(N1): N1 = N1 + 1: Loop Until N1 > UBound(TFus1): GoTo FusS
Fin2: Do: NR = NR + 1: TIdx(NR) = TFus2(N2): N2 = N2 + 1: Loop Until N2 > UBound(TFus2)
FusS: Loop
   Exit Sub
   Dim Arg As Long, C As Long
Comparer:
   For Arg = 1 To ArgMax: C = TCols(Arg)
      Comp = VarComp(TDon(L2, C), TDon(L1, C), TSens(Arg))
      If Comp Then Return
      Next Arg
   Comp = Sgn(L2 - L1): Return
   End Sub
Private Sub InterpréterParam(ByVal ColOrd As Variant, ByVal UBnd2 As Long, ByVal Pour As String)
   Dim P As Long, N As Long
   Call RàZArguments
   For P = LBound(ColOrd) To UBound(ColOrd)
      If IsArray(ColOrd(P)) Then
         For N = LBound(ColOrd(P)) To UBound(ColOrd(P)): AjoutArgument ColOrd(P)(N), UBnd2, Pour: Next N
      Else: AjoutArgument ColOrd(P), UBnd2, Pour: End If
      Next P
   If RupMax > ArgMax Then RupMax = ArgMax
   End Sub
Costaud le code … le temps d'y rentré 😬
L'indexation des lignes pour le tri est une très bonne idée

T'as pensé une fois que tu as toutes les lignes à faire le tri avec un truc du genre ? :
VB:
MonTabTrier = Application.Index(TabATrier, Tab2DTriIndexéLignes, Tab1DdesCol))
??
un exemple en fichier ultra simplifié (ne comprend pas le tri car fait via ta macro) :
pas de boucle … ca peut peut être amélioré ta macro … !! ?
 

Pièces jointes

  • Exemple.xlsm
    9.4 KB · Affichages: 0
Dernière édition:

patricktoulon

XLDnaute Barbatruc
pour le coup j'ai reduit ma double boucle bulle de plus de 40%
VB:
Sub test()
    t = Array(9, 3, 4, 8, 2, 13, 1, 7, 5, 6, 15, 11, 10, 12, 14)
    t = Sort(t)
    MsgBox Join(t, vbCrLf)
   t = Array(9, 3, 4, 8, 2, 13, 1, 7, 5, 6, 15, 11, 10, 12, 14)
    t = Sort2(t)
    MsgBox Join(t, vbCrLf)

End Sub
Function Sort(t)
    Dim temp, I&, A&, q&
    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
        Next
    Next
    MsgBox q & " tours de boucle"
    Sort = t
End Function

Function Sort2(t)
    Dim temp, I&, A&, q&
    For I = LBound(t) To UBound(t) - 1
        For A = I + 1 To UBound(t)
            If A < UBound(t) Then If t(I) < t(A) Then A = A + 1
            If t(I) > t(A) Then temp = t(I): t(I) = t(A): t(A) = temp
            If A < UBound(t) Then If t(A) < t(A + 1) Then tp = t(A): t(A) = t(A + 1): t(A + 1) = tp: A = A + 1
            q = q + 1
        Next
    Next
    MsgBox q & " tours de boucle"
    Sort2 = t
End Function
 

patricktoulon

XLDnaute Barbatruc
diabolo.gif


en l'an 3685 jesuryu s’écria eurêka!!! j'ai trouvé il me faut une douzaine de collection
tu m'en mettra 2 douzaine hein sur mon compte hein !!!
 

Dranreb

XLDnaute Barbatruc
Non ce n'est pas du tout du QuickSort. Pour la 1ère phase se sont des petits tris par insertion jusqu'à tomber sur un élément plus petit que le dernier de la liste d'au moins déjà 20 éléments, auquel cas on arrête de la remplir, on la range dans une collection et on en entame une nouvelle. La phase 2 reprend chaque fois deux de ces listes et les fusionne jusqu'à ce que la collection soit vide.
 

RyuAutodidacte

XLDnaute Impliqué
Hello tous ;)
@patricktoulon
en l'an 3685 jesuryu s’écria eurêka!!! j'ai trouvé il me faut une douzaine de collection
tu m'en mettra 2 douzaine hein sur mon compte hein !!!
quel moqueur ! 🤔 je ne suis pas rivé sans arrêt sur Excel et j'ai un 2ème taf 🤪

@Dranreb
Non ce n'est pas du tout du QuickSort. Pour la 1ère phase se sont des petits tris par insertion jusqu'à tomber sur un élément plus petit que le dernier de la liste d'au moins déjà 20 éléments, auquel cas on arrête de la remplir, on la range dans une collection et on en entame une nouvelle. La phase 2 reprend chaque fois deux de ces listes et les fusionne jusqu'à ce que la collection soit vide.
Ok je comprends mieux donc l'exemple que je t'ai envoyé en fichier ne te servira pas
D'ailleurs je suis tombé sur des explications simples sur le tri ici et je suppose que ton tri et un tri par fusion … ?
 

Dranreb

XLDnaute Barbatruc
Bonjour.
C'est un tri par fusion, mais avec une passe de découpage initiale différente, et sans chercher à diviser forcément par rapport au milieu, ni en nombre puissance de 2. Elle a une histoire d'ailleurs. Dans la 1ère version je faisais des paquets de 2 en mettant le plus petit chaque fois en premier. Puis je me suis aperçu que tant qu'on trouvais des éléments croissants, il n'y avais aucun inconvénient à les ajouter à la même liste. Après j'ai vu que quand on en trouvais un plus petit, mais qu'on n'avait encore que deux éléments, il n'était pas trop difficile de l'y intégrer à la bonne place. Et enfin j'ai encore constaté un gain en faisant carrément un petit tri par insertion avec un optimum difficile à apprécier aux alentours de 25 éléments environs, ce qui était bien plus que je ne m'y attendais, et je me suis finalement arrêté à 20.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
as tu fait des tests de rapidité entres les différents tri existants parmi les plus rapide avec le tien ?

bonjour tout les deux
et oui c'est là qu'il y a résultats mitigé
si l'on 100 /150 donnée a trier le tri fusion sera pas forcement le plus rapide car il faut prendre en compte tout le poids de la mécanique
et le met en rouge tout particulièrement en VBA
car en effet il y a un autre aspect à prendre en compte en VBA c'est sa gestion de mémoire déplorable par rapport a un autre langage
et c'est encore plus d'actualité avec les versions excel d'aujourd'hui
perso j'utilise le bubble ou le bubble avec jump ou le quick sort
je travaille sur vba ou JS ou vb.net
et bien sur ces trois langages pour un même travail sur un array identique ,les résultats pourraient vous surprendre ;)

donc en théorie oui le tri fusion mathématiquement parlant est légèrement plus rapide
viens ensuite le quicksort
et le bubble

mais en pratique selon la quantité de donnée ,le choix de la méthode ne revient qu'au développeur
 

patricktoulon

XLDnaute Barbatruc
re pour donner un exemple de ma bubbleJump
la ou ou tribubble mettra environ nbitem² tours
moi je met environ nbitem*5
exemple ici sur 15 item je passe de
119 tours et 36 intervertions pour la bubble classique
à
58 tours et 30 intervertions pour la bubble jump

j'ai mis un peu de temps a la traduire en vba
VB:
Dim q&
Dim ch&
Sub testBubble()
    q = 0: ch = 0
    t = Array(1, 15, 4, 9, 3, 8, 2, 13, 7, 5, 6, 11, 10, 14, 12)
    t = SortBubble(t)
    MsgBox Join(t, vbCrLf)
End Sub

Sub testBubbleJump()
    q = 0: ch = 0
    t = Array(1, 15, 4, 9, 3, 8, 2, 13, 7, 5, 6, 11, 10, 14, 12)
    t = SortBubbleJump_1_2(t)
    MsgBox Join(t, vbCrLf)
End Sub

Function SortBubble(t)
    Dim temp, I&, A&, q&
    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
    MsgBox q & " tours de boucle et " & ch & " intervertions"
    SortBubble = t
End Function


Function SortBubbleJump_1_2(t)
    Dim temp, I&, A&, q&
    For I = LBound(t) To UBound(t) - 1
        For A = I + 1 To UBound(t)
            A = A + ((Abs(t(I) < t(A)) * Abs(UBound(t) > A))) + ((Abs(t(I) < t(A)) * Abs(UBound(t) - 1 > A)))
            If t(I) > t(A) Then temp = t(I): t(I) = t(A): t(A) = temp: ch = ch + 1
            q = q + 1
        Next
    Next
    MsgBox q & " tours de boucle et " & ch & " intervertions"
    SortBubbleJump_1_2 = t
End Function
 

RyuAutodidacte

XLDnaute Impliqué
@patricktoulon
Bientôt dans les bacs 🤣
VB:
' ***********************************************************************************************************
' Author : RyuAutodidacte
' ||-----------||       \            /     ||             ||
' ||           ||         \        /       ||             ||
' ||           ||           \    /         ||             ||
' ||-----------||             \/           ||             ||
' ||          \               |            ||             ||
' ||            \             |            ||             ||
' ||              \           |            ||             ||
' ||                \         |            ||-------------|| ————— Autodidacte
' ***********************************************************************************************************
Toi tu l'auras en 5372 après jésus Christ sans eurêka !!! 🤣
diabolo.gif

PS : j'ai dû retravailler des fonctions mais me manque toujours le tri :( le temps que je l'ingurgite
Ca sera un Tri sur les items et sur les Clés
 

patricktoulon

XLDnaute Barbatruc
RE

à minima
les "\" deviennent des "\\"
les "/" deviennent de "//"
les "-" deviennent des double sur 2 ligne
tu peux fermer les angles aussi
et tu peux mettre des pieds a tes lettres

si tu veux m'imiter fait le bien
VB:
' ***********************************************************************************************************
' Author : RyuAutodidacte
'   / -----------\
'   ||-----------||       \\            //     ||             ||
'   ||           ||         \\        //       ||             ||
'   ||           ||           \\    //         ||             ||
'   ||===========||             \\//           ||             ||
'   ||          \\               ||            ||             ||
'   ||            \\             ||            ||             ||
'   ||              \\           ||            ||             ||
' __||                \\__    ___||___         ||-------------|| ————— Autodidacte
'                                                \------------/
' ***********************************************************************************************************

ou bien comme ça

Code:
' ***********************************************************************************************************
' Author : RyuAutodidacte
'   _______________       _              _     _ _
'   ||-----------||       \\            //     ||             ||
'   ||           ||         \\        //       ||             ||
'   ||           ||           \\    //         ||             ||
'   ||===========||             \\//           ||             ||
'   ||          \\               ||            ||             ||
'   ||            \\             ||            ||             ||
'   ||              \\           ||            ||             ||
' __||                \\__    ___||___         ||-------------|| ————— Autodidacte
'|---                 |---|  |--------|        |---------------|                                             -----------------
' ***********************************************************************************************************
ou bien encore comme ça

Code:
' ***********************************************************************************************************
' Author : RyuAutodidacte
'     ___________       ____           ____   ____           ____
'   ||-----------||       \\            //     ||             ||
'   ||           ||         \\        //       ||             ||
'   ||___________||           \\    //         ||             ||
'   ||___________||             \\//           ||             ||
'   ||          \\               ||            ||             ||
'   ||            \\             ||            ||             ||
'   ||              \\           ||            ||             ||
' __||                \\__    ___||___         ||_____________|| ————— Autodidacte
' \__|                 |_/    \______/          \_____________/                                             -----------------
'
' ***********************************************************************************************************
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
allez soyons fous en italic
Code:
' ***********************************************************************************************************
'
'    ________    ___    ___    __      ___     __           _      _   _____    ______
'   //     //     ||    //     //      //     //\\         //     //   -----   //----//
'  //_____//       ||  //     //      //     //  \\       //     //    //     //    //
' //      \          //      //      //     //====\\     //     //    //     //    //
'//        \        //        \\____//     //      ||    \\____//    //     //____//====>didacte
'
'**********************************************************************************************************
tiens il est mieux celui là
VB:
' ***********************************************************************************************************
'
'    ________    ___    ___    __      ___     __           _      _   _____    ______
'   //     //     ||    //     //      //     //\\         //     //   -----   //----//
'  //_____//      ||   //     //      //     //  \\       //     //    //     //    //
' //      \\       \\//      //      //     //====\\     //     //    //     //    //
'//       //        //      //______//     //     //    //_____//    //     //____//====>didacte
'
'**********************************************************************************************************

Code:
' ***********************************************************************************************************
'
'    ________   ___    ___   ___    ___     __          ___    ___  _____    ______
'   //     //    ||    //    //     //     //\\         //     //   -----   //----//
'  //_____//      \\  //    //     //     //  \\       //     //    //     //    //
' //      \\       \//     //     //     //====\\     //     //    //     //    //
'//       //       //      \\____//     //     //     \\____//    //     //____//====>didacte
'
'**********************************************************************************************************
 
Dernière édition:

Statistiques des forums

Discussions
315 120
Messages
2 116 441
Membres
112 745
dernier inscrit
mcanas