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 · 11 Novembre 2023

patricktoulon à dit:
j'ai mis la source a jour

oui mais c'est quoi que tu as mis à jour exactement

patricktoulon · 11 Novembre 2023

@Dranreb
re 0.02 sec pour 10 000 items
soit le même que le quicksort tout seul
edit:

VB:

Sub createliste()
    ReDim t(1 To 20000, 1 To 1)
    Cells(1, 1).CurrentRegion.ClearContents
    For i = 1 To 20000
        t(i, 1) = Int(1 + (Rnd * 30000))
    Next
    Cells(1, 1).Resize(20000) = t
    Cells(1.1).Resize(20000).RemoveDuplicates Columns:=1, Header:=xlNo
    Cells(10001, 1).Resize(20000).ClearContents

End Sub
Sub creatliste2()
    Dim t
    [A:A].ClearContents
    t = Evaluate("ROW(1:10000)")
    For i = 1 To UBound(t)
        x = Int(1 + (Rnd * 10000))
        tp = t(i, 1): t(i, 1) = t(x, 1): t(x, 1) = tp
    Next
    Cells(1, 1).Resize(10000) = t

End Sub
Sub test()
    Dim Tdon, tim#
    Tdon = Application.Transpose([A1].CurrentRegion.Value)
    tim = Timer
    PartitAmél Tdon, 1, 10000
    MsgBox Format(Timer - tim, "#0.00") & "sec"
    Cells(1, 3).Resize(10000) = Application.Transpose(Tdon)
End Sub

Private Sub PartitAmél(Tdon, ByVal Min As Long, ByVal Max As Long)
    Dim VPiv, Crs As Long, Dcr As Long, V, _
      R As Long, Arg, Mn As Long, Mx As Long, S As Long
    If Max - Min > 20 Then
        VPiv = Tdon(Min + Int(Rnd * (Max - Min + 1)))
        Crs = Min: Dcr = Max
        Do While Crs <= Dcr
            Do While Tdon(Crs) < VPiv: Crs = Crs + 1: Loop
            Do While VPiv < Tdon(Dcr): Dcr = Dcr - 1: Loop
            If Crs <= Dcr Then
                V = Tdon(Crs): Tdon(Crs) = Tdon(Dcr): Tdon(Dcr) = V
                Crs = Crs + 1: Dcr = Dcr - 1
            End If
        Loop    ' While Crs <= Dcr
        If Crs < Max Then PartitAmél Tdon, Crs, Max
        If Min < Dcr Then PartitAmél Tdon, Min, Dcr
    Else
        For R = Min + 1 To Max: Arg = Tdon(R)
            Mn = Min: Mx = R
            Do: S = (Mn + Mx) \ 2
                If Tdon(S) <= Arg Then Mn = S + 1 Else Mx = S
            Loop Until Mx <= Mn
            For S = R To Mn + 1 Step -1: Tdon(S) = Tdon(S - 1): Next S
            Tdon(S) = Arg
        Next R
    End If
End Sub

patricktoulon · 11 Novembre 2023

RyuAutodidacte à dit:
oui mais c'est quoi que tu as mis à jour exactement

le fichier et la vidéo

patricktoulon · 11 Novembre 2023

en revanche la partie dichotomique est plus rapide que mon insertBubble
1.50 sec pour la dichotomique contre 2.72 pour la insertBubble sur 10 000 items
c'est une belle performence aussi 👍

Code:

Sub createliste()
    ReDim t(1 To 20000, 1 To 1)
    Cells(1, 1).CurrentRegion.ClearContents
    For i = 1 To 20000
        t(i, 1) = Int(1 + (Rnd * 30000))
    Next
    Cells(1, 1).Resize(20000) = t
    Cells(1.1).Resize(20000).RemoveDuplicates Columns:=1, Header:=xlNo
    Cells(10001, 1).Resize(20000).ClearContents

End Sub
Sub creatliste2()
    Dim t
    [A:A].ClearContents
    t = Evaluate("ROW(1:10000)")
    For i = 1 To UBound(t)
        x = Int(1 + (Rnd * 10000))
        tp = t(i, 1): t(i, 1) = t(x, 1): t(x, 1) = tp
    Next
    Cells(1, 1).Resize(10000) = t

End Sub
Sub test()
    Dim Tdon, tim#
    Tdon = Application.Transpose([A1].CurrentRegion.Value)
    tim = Timer
    SortDichotomique Tdon, 1, 10000
    MsgBox Format(Timer - tim, "#0.00") & "sec"
    Cells(1, 3).Resize(10000) = SortDichotomique(Tdon)
End Sub

Function SortDichotomique(Tdon, Optional ByVal Min As Long = -1, Optional ByVal Max As Long = -1)
    Dim VPiv, Crs As Long, Dcr As Long, V, R As Long, Arg, Mn As Long, Mx As Long, S As Long
     If Min = -1 Then Min = LBound(Tdon)
     If Max = -1 Then Max = UBound(Tdon)
           For R = Min + 1 To Max: Arg = Tdon(R)
            Mn = Min: Mx = R
            Do: S = (Mn + Mx) \ 2
                If Tdon(S) <= Arg Then Mn = S + 1 Else Mx = S
            Loop Until Mx <= Mn
            For S = R To Mn + 1 Step -1: Tdon(S) = Tdon(S - 1): Next S
            Tdon(S) = Arg
        Next R
SortDichotomique = Application.Transpose(Tdon)
End Function

patricktoulon · 11 Novembre 2023

re

VB:

'******************************************************************************************************************************************************
'    ___      __      _       _     _    __      ____    ___
'   // ||    // \\   /\\     //|   //   // \\   //      // \\
'  //  ||   //__//  //__\   // |  //   //__//  //__    //_ //
' //   //  //  \\  //   \\ //  | //   //  \\  //      //   \\
'//___//  //   // //    ////   |//   //   // //___   //____//
'******************************************************************************************************************************************************
'méthode 7
'Auteur Dranreb sur Exceldownloads
'date:11/11/2023
'rédigé sous la forme d'une fonction par patricktoulon
'principe utilisé :recherche dichotomique
'fait partie des principes dit avec Pivot
'on va prendre comme pivot le milieu et on va tester le mileu   dela partie du debut a la fin correspondant au milieu de l'array entier
'si on trouve on deplace  sinon on recommence en augmentant la  min +1
'une autre boucle faire le bubble de r= mn par pas de -1
'le tout dans une boucle répéteuse de lbound+1 a max

Dim Q&, Ch&
Sub createliste() 'liste avec manquant
    ReDim t(1 To 20000, 1 To 1)
    Cells(1, 1).CurrentRegion.ClearContents
    For i = 1 To 20000
        t(i, 1) = Int(1 + (Rnd * 30000))
    Next
    Cells(1, 1).Resize(20000) = t
    Cells(1.1).Resize(20000).RemoveDuplicates Columns:=1, Header:=xlNo
    Cells(10001, 1).Resize(20000).ClearContents

End Sub
Sub creatliste2() 'liste sans manquants
    Dim t
    [A:A].ClearContents
    t = Evaluate("ROW(1:10000)")
    For i = 1 To UBound(t)
        x = Int(1 + (Rnd * 10000))
        tp = t(i, 1): t(i, 1) = t(x, 1): t(x, 1) = tp
    Next
    Cells(1, 1).Resize(10000) = t

End Sub
Sub test()
    Dim Tdon, tim#
    Tdon = Application.Transpose([A1].CurrentRegion.Value)
    tim = Timer
    Tdon = SortDichotomique(Tdon)
    msg = Format(Timer - tim, "#0.00") & " secondes" & vbCrLf & Q & " tours de boucle" & vbCrLf & Ch & " interversions"
    Cells(1, 3).Resize(UBound(Tdon)) = Tdon
    #If Not Mac Then
        Application.Speech.Speak msg, True
    #End If
    MsgBox msg
End Sub

Function SortDichotomique(Tdon, Optional ByVal Min As Long = -1, Optional ByVal Max As Long = -1)
    Dim VPiv, Crs As Long, Dcr As Long, V, R As Long, Arg, Mn As Long, Mx As Long, S As Long
    If Min = -1 Then Min = LBound(Tdon)
    If Max = -1 Then Max = UBound(Tdon)
    For R = Min + 1 To Max: Arg = Tdon(R)
        Mn = Min: Mx = R
        Do: S = (Mn + Mx) \ 2
            If Tdon(S) <= Arg Then Mn = S + 1 Else Mx = S
            Q = Q + 1
        Loop Until Mx <= Mn
        For S = R To Mn + 1 Step -1: Tdon(S) = Tdon(S - 1): Q = Q + 1: Ch = Ch + 1: Next S
        Tdon(S) = Arg
    Next R
    SortDichotomique = Application.Transpose(Tdon)
End Function

RyuAutodidacte · 11 Novembre 2023

Patrick
j'ai tenté le mixte Dranreb/Ryu

Quelle est la différence entre ces 2 captures :

La prise en compte du comptage de Q et ch

VB:

Function SortDichotomique(Tdon, Optional ByVal Min As Long = -1, Optional ByVal Max As Long = -1)
    Dim VPiv, Crs As Long, Dcr As Long, V, R As Long, Arg, Mn As Long, Mx As Long, S As Long
     If Min = -1 Then Min = LBound(Tdon)
     If Max = -1 Then Max = UBound(Tdon)
           For R = Min + 1 To Max: Arg = Tdon(R)
            Mn = Min: Mx = R
            Do: S = (Mn + Mx) \ 2
                If Tdon(S) <= Arg Then Mn = S + 1 Else Mx = S
            Loop Until Mx <= Mn
            For S = R To Mn + 1 Step -1: Tdon(S) = Tdon(S - 1): Next S
            Tdon(S) = Arg
        Next R
SortDichotomique = Tdon
End Function
'Function SortDichotomique(Tdon, Optional ByVal Min As Long = -1, Optional ByVal Max As Long = -1)
'    Dim VPiv, Crs As Long, Dcr As Long, V, R As Long, Arg, Mn As Long, Mx As Long, S As Long
'    If Min = -1 Then Min = LBound(Tdon)
'    If Max = -1 Then Max = UBound(Tdon)
'    For R = Min + 1 To Max: Arg = Tdon(R)
'        Mn = Min: Mx = R
'        Do: S = (Mn + Mx) \ 2
'            If Tdon(S) <= Arg Then Mn = S + 1 Else Mx = S
'            Q = Q + 1
'        Loop Until Mx <= Mn
'        For S = R To Mn + 1 Step -1: Tdon(S) = Tdon(S - 1): Q = Q + 1: ch = ch + 1: Next S
'        Tdon(S) = Arg
'    Next R
'    SortDichotomique = Tdon
'End Function

patricktoulon · 11 Novembre 2023

re
mais non
l'original de @Dranreb de lbound à 20 utilise le dichotomique et pour le reste le qicksort
c'est ça la différence saucisse!!!
j'ai simplement (dans le 2d exemple )séparé le dichotomique du quicksort pour voir vraiment ce que ca valait
il est plus rapide que le insertBubbleGD d'un peu plus d'une seconde
donc on engrange dans le recueil

RyuAutodidacte · 11 Novembre 2023

patricktoulon à dit:
c'est ça la différence saucisse!!!

Mais non saucisse j'ai seulement utilisé la function SortDichotomique 🤣 avec mon pré tri
Dans l'une tu y a ajouté le comptage de Q et de Ch, et bien ca apparait anodin comme type de cacul de faire un simple Q = Q +1 et Ch = Ch +1 , ca fais qd meme une diff de pesque 0,15

patricktoulon · 11 Novembre 2023

re
pour mesurer la quellle est la plus rapide il faut bien que toutes les calcule non? sinon tes résultats sont faussés

RyuAutodidacte · 11 Novembre 2023

oui je sais mais je ne pensais pas que ça prenais autant (même si cela paraît dérisoire)

patricktoulon · 11 Novembre 2023

dans la vidéo j'en parle justement de ca
le fait d'incrémenter une variable dans une boucle do loop augmente un peu
elle dure plus d'une heure

dysorthographie · 11 Novembre 2023

bonjour,
je ne sais pas ce que ça vaut!

VB:

Sub TrieDicotomique(Dico As Collection, Value As String, Index As Integer)
Dim Min As Integer, Max As Integer, i As Integer
Select Case Dico.Count
    Case 0: Dico.Add Array(Value, Index)
    Case 1: If Dico(1)(0) < Value Then Dico.Add Array(Value, Index) Else Dico.Add Array(Value, Index), before:=1
    Case Else
    Min = 1: Max = Dico.Count
    Do While Max <> Min
        If Dico(Min)(0) >= Value Then Dico.Add Array(Value, Index), before:=Min: Exit Sub
        If Dico(Max)(0) <= Value Then Dico.Add Array(Value, Index), after:=Max: Exit Sub
        If Max - Min = 1 Then
           If Dico(Min)(0) <= Value And Dico(Max)(0) => Value Then Dico.Add Array(Value, Index), before:=Max: Exit Sub
        End If
        i = Min + ((Max - Min) / 2)
        If Dico(i)(0) < Value Then
            Min = i
        Else
            Max = i
        End If
    Loop
   
End Select
End Sub

Sub test()
Dim t(1 To 20000) As String, i As Integer
Randomize Timer
For i = 1 To 20000
   t(i) = Chr(64 + (Int((26 * Rnd) + 1)))
Next

Dim Dico As New Collection
For i = 1 To 20000
   TrieDicotomique Dico, t(i), i
Next
For i = 1 To 20000
    ActiveCell.Offset(i) = Dico(i)(0)
Next
Dim CROISSAN(1 To 20000) As String

For i = 1 To 20000
    CROISSAN(i) = t(Dico(i)(1))
Next
Dim Ti As Integer, DECROISSAN(1 To 20000) As String

For i = 20000 To 1 Step -1
Ti = Ti + 1
    DECROISSAN(Ti) = t(Dico(i)(1))
Next
End Sub

patricktoulon · 12 Novembre 2023

j'ai fait des debug pour voir comment fonctionnait le dichotomique
au final sur 10000 item on gagne 100 à 1500 tours apeu près par rapport au bubble
par contre les replcaes ça fuse
pourtant on est moins long
des fois j'en perd le nord
tester sur un array de 10

VB:

Dim Q&, Ch&

Sub test_dichotomique()
   Q = 0: Ch = 0
   Dim Tdon, tim#
    Tdon = Application.Transpose([A1:a10].Value)
    tim = Timer
    Tdon = SortDichotomique(Tdon)
    msg = Format(Timer - tim, "#0.00") & " secondes" & vbCrLf & Q & " tours de boucle" & vbCrLf & Ch & " interversions"
    Cells(1, 3).Resize(UBound(Tdon)) = Tdon
    #If Not Mac Then
        Application.Speech.Speak msg, True
    #End If
    MsgBox msg
End Sub

Function SortDichotomique(Tdon, Optional ByVal Min As Long = -1, Optional ByVal Max As Long = -1)
    Dim VPiv, Crs As Long, Dcr As Long, V, R As Long, Arg, Mn As Long, Mx As Long, S As Long
    If Min = -1 Then Min = LBound(Tdon)
    If Max = -1 Then Max = UBound(Tdon)
    For R = Min + 1 To Max: Arg = Tdon(R)
      Debug.Print "arg : " & Arg & " index : " & R
      Mn = Min: Mx = R
      Do: S = (Mn + Mx) \ 2
       Debug.Print "portion de  :" & Mn & " à : " & Mx
     If Tdon(S) <= Arg Then Mn = S + 1 Else Mx = S
        Debug.Print "test de l'index du milieu: index :" & S
          Q = Q + 1
        Loop Until Mx <= Mn
        For S = R To Mn + 1 Step -1: Tdon(S) = Tdon(S - 1): Q = Q + 1: Ch = Ch + 1: Next S
        Tdon(S) = Arg
    Debug.Print Join(Tdon, ",")
    Debug.Print "**************************************"
    Next R
    SortDichotomique = Application.Transpose(Tdon)
End Function

mon resultat

arg : 9 index : 2
portion de :1 à : 2
test de l'index du milieu: index :1
5,9,3,7,1,6,4,8,2,10
**************************************
arg : 3 index : 3
portion de :1 à : 3
test de l'index du milieu: index :2
portion de :1 à : 2
test de l'index du milieu: index :1
3,5,9,7,1,6,4,8,2,10
**************************************
arg : 7 index : 4
portion de :1 à : 4
test de l'index du milieu: index :2
portion de :3 à : 4
test de l'index du milieu: index :3
3,5,7,9,1,6,4,8,2,10
**************************************
arg : 1 index : 5
portion de :1 à : 5
test de l'index du milieu: index :3
portion de :1 à : 3
test de l'index du milieu: index :2
portion de :1 à : 2
test de l'index du milieu: index :1
1,3,5,7,9,6,4,8,2,10
**************************************
arg : 6 index : 6
portion de :1 à : 6
test de l'index du milieu: index :3
portion de :4 à : 6
test de l'index du milieu: index :5
portion de :4 à : 5
test de l'index du milieu: index :4
1,3,5,6,7,9,4,8,2,10
**************************************
arg : 4 index : 7
portion de :1 à : 7
test de l'index du milieu: index :4
portion de :1 à : 4
test de l'index du milieu: index :2
portion de :3 à : 4
test de l'index du milieu: index :3
1,3,4,5,6,7,9,8,2,10
**************************************
arg : 8 index : 8
portion de :1 à : 8
test de l'index du milieu: index :4
portion de :5 à : 8
test de l'index du milieu: index :6
portion de :7 à : 8
test de l'index du milieu: index :7
1,3,4,5,6,7,8,9,2,10
**************************************
arg : 2 index : 9
portion de :1 à : 9
test de l'index du milieu: index :5
portion de :1 à : 5
test de l'index du milieu: index :3
portion de :1 à : 3
test de l'index du milieu: index :2
portion de :1 à : 2
test de l'index du milieu: index :1
1,2,3,4,5,6,7,8,9,10
**************************************
arg : 10 index : 10
portion de :1 à : 10
test de l'index du milieu: index :5
portion de :6 à : 10
test de l'index du milieu: index :8
portion de :9 à : 10
test de l'index du milieu: index :9
1,2,3,4,5,6,7,8,9,10
**************************************

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

patricktoulon

XLDnaute Barbatruc

Pièces jointes

patricktoulon

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

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

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

Privacy & Transparency

Privacy & Transparency