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

Re,

Pas d'avis sur :

RyuAutodidacte à dit:
Autre chose qui me dérange (vrai ou faux pb ?), c'est d'avoir 'DicoC.OverWrit = True' (ou même pour le cumule) en début de code qui agit de manière globale et non sélective …
Dans une même procédure, il peut y avoir des conditions où l'overwrite et/ou le cumule peuvent s'appliquer ou non selon les cas …

???

patricktoulon à dit:
par contre sur windows variable tableau 1 dim ou 2 dim limite pareille 65536

C'est bien pour ça que je demandais la version d'Excel …
- Toi tu es sur 2013 donc Tab 1D ou 2D du pareil au même concernant la limite qui dépasse 65536
- Moi sur Office 365, Tab 1D NOK Tab 2D OK concernant la limite qui dépasse 65536

Ca serait bien de savoir pour les versions ultérieure à Excel 2013

patricktoulon · 2 Novembre 2023

c'est pareil pour tout les windows
peut être que sur mac c'est différent (mais ça m'étonnerait)
en tout cas au boulot les fonctions transpose , Match ne fonctionnent qu'avec une limite de 65536 sur les array et tableau 2 dim
par contre sur une plage la limite est le rows.count de la feuille
au boulot on a des 2016 , 365 avec 2019 et 365 avec 2021

patricktoulon · 2 Novembre 2023

re

VB:

Sub test()
   Dim t(), maxi&, plage As Range
   Randomize
    maxi = 65536
    'maxi = Rows.Count'débloquer cette ligne pour aller plus loin
      Set plage = Cells(1, 1).Resize(maxi)
   ReDim Preserve t(1 To maxi, 1 To 1)
    For i = 1 To UBound(t)
        t(i, 1) = Int(1 + (Rnd * (maxi + 1)))
    Next
    
    t(Int(1 + (Rnd * (maxi))), 1) = "toto" ' on met "toto" au hasard dans le tableau
    
    plage.Value = t
    
    
    x = Application.Match("toto", plage, 0)
    MsgBox "toto en ligne : " & x

    x = Application.Match("toto", t, 0)
    MsgBox "toto en ligne : " & x
End Sub

patricktoulon · 3 Novembre 2023

A l'attention de @laurent950
désolé pour toi mais ton code quicksort à rallonge provoque des erreurs de tri
elle sera donc retirer de la ressource

RyuAutodidacte · 3 Novembre 2023

Re @patricktoulon , bonjour @laurent950

Le code de Laurent est ok, il y a juste une petite erreur de logique que j'ai rectifié … :

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) <====== NON
 
    ' Trouver la plus grande valeur dans le tableau Ta
    maxValeur = Application.WorksheetFunction.Max(Ta)
 
    ' Redimensionner Tb pour correspondre à la taille de maxValeur
    ReDim Tb(1 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 maxValeur
        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

Bien sur ce code ne marche que pour les entiers

patricktoulon · 3 Novembre 2023

heu ryu il faut suivre
je parle de son quicksort à rallonge ici

patricktoulon · 3 Novembre 2023

@laurent950 corrige le si tu peux en l’état c'est inutilisable
j'avais pas fait attention j'aurais du

RyuAutodidacte · 3 Novembre 2023

patricktoulon à dit:
heu ryu il faut suivre
je parle de son quicksort à rallonge ici

OK, … mdr … celui ci avait besoin d'être corrigé aussi
et si tu veux prendre les nombres négatif @laurent :

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 = minValeur To maxValeur
        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

patricktoulon · 3 Novembre 2023

re
on s’égare un peu là

RyuAutodidacte · 4 Novembre 2023

Re Patrick,

patricktoulon à dit:
on s’égare un peu là

Heu non pas vraiment car là tu parlais de tri (même si on parlait pas du même code car je pensais que tu parlais de de celui-ci …) ce code est plus rapide que le QuickSort pour les entiers

patricktoulon · 4 Novembre 2023

@RyuAutodidacte
quand je dis que l'on s'égare c'est que le tri c’était pour le dictionnaire

@laurent950 tu me le corrige ou pas ton quicksort modulé ?

j’aimerais que l'on revienne un peu sur ça et tu fournisse enfin un truc fini au lieu de te disperser
afin que ça devienne pas une discussion foutoir ce qui est déjà pas mal avancé

et pour info cette méthode est connue c'est de l'ordre du débutant
je vous place au dessus de ça quand même

laurent950 · 4 Novembre 2023

Bonsoir @patricktoulon

patricktoulon à dit:
@laurent950 tu me le corrige ou pas ton quicksort modulé ?

Modification dans les Fonctions :
PartitionCroissant :
Do
Do
i = i + 1
On Error Resume Next ' Le i incrémente supérieur a la dernière case du tableau arr
Loop While arr(i, 1) < pivot And i <= high
On Error GoTo 0
Do
j = j - 1
Loop While arr(j, 1) > pivot

et

PartitionDecroissant :
Do
i = i + 1
On Error Resume Next ' Le i incrémente supérieur a la dernière case du tableau arr
Loop While arr(i, 1) > pivot And i <= high ' Changer pour le tri décroissant
On Error GoTo 0

Do
j = j - 1
Loop While arr(j, 1) < pivot

Pour le TrisCroissant

VB:

Sub TestQuickSortCroissant()
    Dim t() As Variant
    Range(Cells(2, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3)).Clear
    t = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 1))
 
    tt = Timer()
    IntroSort t
    MsgBox Timer() - tt
 
    ' Afficher le tableau tris Croissant
    Cells(2, 3).Resize(UBound(t, 1), UBound(t, 2)) = t
    'Dim i As Long
    'For i = LBound(t) To UBound(t)
        'Debug.Print t(i)
    'Next i
End Sub

Sub IntroSort(arr() As Variant)
    Dim low As Long, high As Long
    low = LBound(arr)
    high = UBound(arr)
    IntroSortRecursive arr, low, high, 2 * Log2(high - low + 1)
End Sub

Sub IntroSortRecursive(arr() As Variant, ByVal low As Long, ByVal high As Long, ByVal maxDepth As Long)
    If high <= low Then Exit Sub
    If maxDepth = 0 Then
        ' Si la profondeur maximale est atteinte, utilisez un algorithme de tri plus simple (par exemple, le tri par insertion).
        InsertionSort arr, low, high
    Else
        Dim pivotIndex As Long
        pivotIndex = PartitionCroissant(arr, low, high)
        IntroSortRecursive arr, low, pivotIndex - 1, maxDepth - 1
        IntroSortRecursive arr, pivotIndex + 1, high, maxDepth - 1
    End If
End Sub

Function PartitionCroissant(arr() As Variant, ByVal low As Long, ByVal high As Long) As Long
    Dim pivot As Variant
    pivot = arr(low, 1)
    Dim i As Long
    Dim j As Long
    i = low
    j = high + 1
 
    Do
        Do
            i = i + 1
        On Error Resume Next
        Loop While arr(i, 1) < pivot And i <= high
        On Error GoTo 0
        Do
            j = j - 1
        Loop While arr(j, 1) > pivot
    
        If i < j Then
            ' Échanger les éléments
            Dim temp As Variant
            temp = arr(i, 1)
            arr(i, 1) = arr(j, 1)
            arr(j, 1) = temp
        End If
    Loop While i < j
 
    ' Échanger pivot avec l'élément à la position j
    arr(low, 1) = arr(j, 1)
    arr(j, 1) = pivot
 
    PartitionCroissant = j
End Function

Sub InsertionSort(arr() As Variant, ByVal low As Long, ByVal high As Long)
    Dim i As Long, j As Long
    For i = low + 1 To high
        j = i
        While j > low And arr(j, 1) < arr(j - 1, 1)
            Swap arr(j, 1), arr(j - 1, 1)
            j = j - 1
        Wend
    Next
End Sub

Sub Swap(ByRef a As Variant, ByRef b As Variant)
    Dim temp As Variant
    temp = a
    a = b
    b = temp
End Sub

Function Log2(ByVal x As Double) As Long
    Log2 = WorksheetFunction.RoundDown(Log(x) / Log(2), 0)
End Function

pour le TrisDecroissant

Code:

Sub TestQuickSortDecroissant()
    Dim t() As Variant
    Range(Cells(2, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3)).Clear
    t = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 1))
 
    tt = Timer()
    IntroSort t
    MsgBox Timer() - tt
 
    ' Afficher le tableau tris Croissant
    Cells(2, 3).Resize(UBound(t, 1), UBound(t, 2)) = t
    'Dim i As Long
    'For i = LBound(t) To UBound(t)
        'Debug.Print t(i)
    'Next i
End Sub

Sub IntroSort(arr() As Variant)
    Dim low As Long, high As Long
    low = LBound(arr)
    high = UBound(arr)
    IntroSortRecursive arr, low, high, 2 * Log2(high - low + 1)
End Sub

Sub IntroSortRecursive(arr() As Variant, ByVal low As Long, ByVal high As Long, ByVal maxDepth As Long)
    If high <= low Then Exit Sub
    If maxDepth = 0 Then
        ' Si la profondeur maximale est atteinte, utilisez un algorithme de tri plus simple (par exemple, le tri par insertion).
        InsertionSort arr, low, high
    Else
        Dim pivotIndex As Long
        pivotIndex = PartitionDecroissant(arr, low, high)
        IntroSortRecursive arr, low, pivotIndex - 1, maxDepth - 1
        IntroSortRecursive arr, pivotIndex + 1, high, maxDepth - 1
    End If
End Sub

Function PartitionDecroissant(arr() As Variant, ByVal low As Long, ByVal high As Long) As Long
    Dim pivot As Variant
    pivot = arr(low, 1)
    Dim i As Long
    Dim j As Long
    i = low
    j = high + 1
 
    Do
        Do
            i = i + 1
        On Error Resume Next
        Loop While arr(i, 1) > pivot And i <= high ' Changer pour le tri décroissant
        On Error GoTo 0
    
        Do
            j = j - 1
        Loop While arr(j, 1) < pivot
    
        If i < j Then
            ' Échanger les éléments
            Dim temp As Variant
            temp = arr(i, 1)
            arr(i, 1) = arr(j, 1)
            arr(j, 1) = temp
        End If
    Loop While i < j
 
    ' Échanger pivot avec l'élément à la position j
    arr(low, 1) = arr(j, 1)
    arr(j, 1) = pivot
 
    PartitionDecroissant = j
End Function


Sub InsertionSort(arr() As Variant, ByVal low As Long, ByVal high As Long)
    Dim i As Long, j As Long
    For i = low + 1 To high
        j = i
        While j > low And arr(j, 1) < arr(j - 1, 1)
            Swap arr(j, 1), arr(j - 1, 1)
            j = j - 1
        Wend
    Next
End Sub

Sub Swap(ByRef a As Variant, ByRef b As Variant)
    Dim temp As Variant
    temp = a
    a = b
    b = temp
End Sub

Function Log2(ByVal x As Double) As Long
    Log2 = WorksheetFunction.RoundDown(Log(x) / Log(2), 0)
End Function

J'ai mis en place un générateur de listes qui crée des séries de nombres incrémentés de manière aléatoire pour réaliser des tests. Ce générateur a pour but de produire des ensembles de données non ordonnés à des fins de validation ou de vérification, Croissant et Décroissant.

Module stnadard(GenerateurPourTris)

Code:

Sub CreerDesordreTotal()
    Dim tableau(1 To 64000) As String
    Dim i As Long
    Dim nom As String
    
    ' Remplissage du tableau avec une séquence de noms
    For i = 1 To 64000
        nom = "Nom" & Format(i, "00000")
        tableau(i) = nom
    Next i
    
    ' Mélanger le tableau pour créer un désordre total
    Randomize
    For i = 1 To 64000
        ' Échanger chaque élément avec un autre élément aléatoire
        Dim temp As String
        Dim j As Long
        j = Int((64000 - i + 1) * Rnd + i)
        temp = tableau(i)
        tableau(i) = tableau(j)
        tableau(j) = temp
    Next i
    
    ' Clear
    Range(Cells(2, 1), Cells(UBound(tableau) + 1, 1)).Clear
    
    ' Afficher quelques éléments du tableau pour vérification
    For i = LBound(tableau) To UBound(tableau)
        Cells(i + 1, 1) = tableau(i)
    Next i
    ' Pour test resultat
    'For i = 1 To 20
        'Debug.Print tableau(i)
    'Next i

patricktoulon · 6 Novembre 2023

re
quand j'ai testé la bubble et la insertion (qui sont les plus lentes )

la bubble environ 8 secondes pour 10000 items
la insertion environ 7.5 seconde

j'ai voulu testé pour le fun et faire des petites expériences de mélanger les deux principes

a ma grande surprise je dive par environ 3 le temps de tri

pour rappel

1°la méthode bubble consiste à;
dans une double boucle (to ubound et -1 pour la boucle 1) intervertir l'item boucle 1 et l'item boucle2

2° la méthode insertion consiste en une double boucle
la première de lbound to ubound
et la second de lbound to index boucle 1
et interversion

3°ce coup si
je fait 1 boucles de lbound to ubound et une autre boucle de index boucle 1 a ubound
je cherche le plus petit et en sorti de boucle2 donc toujours dans la boucle 1 j’intervertis
ce qui fait que comme je boucle de lbound a ubound pour la boucle 1
l' interversion se produit qu'une seule fois
donc a chaque tour mes items boucles1 sont a leur place définitive
résultat de 7/8 secondes je tombe à 2/4 seconde
alors oui on est encore loin des quicksort et fusion
mais cet exercice nous permet de constater que c'est pas forcement les tours de boucle qui sont les plus longue c'est bien les interversions
ici toujours sur 10 000 items on a maximum 10 000 interversions et pas une de plus
je l'ai nommé "sortInsertBubble"
le message est eloquant quand on regarde les chiffres

VB:

Dim Q
Dim ch
Sub qqq()
    ReDim t(1 To 15000, 1 To 1)
    For i = 1 To 15000
        t(i, 1) = Int(1 + (Rnd * 30000))

    Next
    With Cells(1, 1).Resize(15000)
        .Value = t
        .RemoveDuplicates Columns:=1, Header:=xlNo
    End With
    Cells(10001, 1).Resize(5000).ClearContents
End Sub

Sub test()
    Dim t, tim#
    t = Application.Transpose([A1:A10000].Value)
    tim = Timer
    t = sortInsertBubble(t)
    MsgBox Format(Timer - tim, "#0.00 ""sec""") & vbCrLf & Q & " tours" & vbCrLf & ch & " intervertions"
    Cells(1, 3).Resize(10000).Value = Application.Transpose(t)
End Sub

Function sortInsertBubble(t)
    Dim A&, B&, C&, X&
    For A = LBound(t) To UBound(t)
        ref = t(A)
        X = A
        For B = A + 1 To UBound(t)
            Q = Q + 1
            If ref > t(B) Then ref = t(B): X = B
        Next B
        If X <> A Then tp = t(A): t(A) = t(X): t(X) = tp: ch = ch + 1
    Next A
    sortInsertBubble = t
End Function

patricktoulon · 6 Novembre 2023

re
@laurent950 j'ai vu dans ton nouvel essai que tu a séparé le croissant du décroissant
n'y a t’il pas moyen de faire ça en une comme ta précédente

patricktoulon · 6 Novembre 2023

re
suite de mes expériences :
fort de cette petite découverte je me suis dit allez on essaie d'améliorer la chose
alors j'ai dans l'idé de faire non pas un pivot avec une valeur mais de faire un middle de boucle
j'entends par là que la seconde boucle ne boucle pas j'usqu'au ubound mais a moitié
pour cela on reprend l'idée du quicksort c'est a dire en avancant et à reculons
et cela dans une seule boucle
résultat
en 2d boucle je tourne exactement 2 fois moins
et la surprise
j'ai bien exactement 2 fois moins de tours effectués toujours autant d'interversions

mais je suis bien intrigué par l’illogisme du résultat de temps je met entre 4/5 seconde au lieu de 2/3 pour la simple boucle ubound complète
vous verrez les résultats tombent dans les msgbox

là je vous le dit il faudra m'expliquer et me convaincre que la chose n'est pas bizarre

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

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes