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

patricktoulon · 17 Octobre 2023

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

patricktoulon · 18 Octobre 2023

allez version finale

RyuAutodidacte · 24 Octobre 2023

@patricktoulon

patricktoulon à dit:
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é

patricktoulon à dit:
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

Dranreb à dit:

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 … !! ?

patricktoulon · 24 Octobre 2023

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

RyuAutodidacte · 24 Octobre 2023

Re @Dranreb
dsl j'avais mis la macro dans les macros personnels revoilà le fichier :

patricktoulon · 24 Octobre 2023

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 · 24 Octobre 2023

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 · 25 Octobre 2023

Hello tous
@patricktoulon

patricktoulon à dit:
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

Dranreb à dit:
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 · 25 Octobre 2023

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.

RyuAutodidacte · 25 Octobre 2023

@Dranreb
Super la façon dont tu as optimisé au fur et à mesure ton tri fusion

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

patricktoulon · 25 Octobre 2023

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

Dranreb · 25 Octobre 2023

J'ai longtemps appliqué un QuickSort un peu spécial dans sa manière d'acquérir les données, aussi en mode indexation, mais que j'ai dû abandonner quand j'ai vu qu'au moins dans ce mode la fusion était plus performante.

patricktoulon · 25 Octobre 2023

re bonjour @Dranreb
oui avec un paquet de données important
avec un simple array de 50 items par exemple le quicksort ira plus vite et sera surtout moins lourd
et je dis bien en VBA pas avec un autre language

patricktoulon · 25 Octobre 2023

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 · 25 Octobre 2023

@patricktoulon

@Dranreb @dysorthographie @laurent950 …

Bientôt dans les bacs

VB:

' ***********************************************************************************************************
' Author : RyuAutodidacte
' ||-----------||       \            /     ||             ||
' ||           ||         \        /       ||             ||
' ||           ||           \    /         ||             ||
' ||-----------||             \/           ||             ||
' ||          \               |            ||             ||
' ||            \             |            ||             ||
' ||              \           |            ||             ||
' ||                \         |            ||-------------|| ————— Autodidacte
' ***********************************************************************************************************

Toi tu l'auras en 5372 après jésus Christ sans eurêka !!!

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 · 25 Octobre 2023

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
' \__|                 |_/    \______/          \_____________/                                             -----------------
'
' ***********************************************************************************************************

patricktoulon · 25 Octobre 2023

allez soyons fous en italic

Code:

' ***********************************************************************************************************
'
'    ________    ___    ___    __      ___     __           _      _   _____    ______
'   //     //     ||    //     //      //     //\\         //     //   -----   //----//
'  //_____//       ||  //     //      //     //  \\       //     //    //     //    //
' //      \          //      //      //     //====\\     //     //    //     //    //
'//        \        //        \\____//     //      ||    \\____//    //     //____//====>didacte
'
'**********************************************************************************************************

tiens il est mieux celui là

VB:

' ***********************************************************************************************************
'
'    ________    ___    ___    __      ___     __           _      _   _____    ______
'   //     //     ||    //     //      //     //\\         //     //   -----   //----//
'  //_____//      ||   //     //      //     //  \\       //     //    //     //    //
' //      \\       \\//      //      //     //====\\     //     //    //     //    //
'//       //        //      //______//     //     //    //_____//    //     //____//====>didacte
'
'**********************************************************************************************************

Code:

' ***********************************************************************************************************
'
'    ________   ___    ___   ___    ___     __          ___    ___  _____    ______
'   //     //    ||    //    //     //     //\\         //     //   -----   //----//
'  //_____//      \\  //    //     //     //  \\       //     //    //     //    //
' //      \\       \//     //     //     //====\\     //     //    //     //    //
'//       //       //      \\____//     //     //     \\____//    //     //____//====>didacte
'
'**********************************************************************************************************

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

patricktoulon

XLDnaute Barbatruc

Pièces jointes

patricktoulon

RyuAutodidacte

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc