Fisher-yates KO en vba

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

patricktoulon

XLDnaute Barbatruc
Expérience pratique : Pourquoi “Fisher-Yates” n’est pas toujours la meilleure option en VBA

Bonjour à tous,
cette question est venue sur le forum diverse fois (tirage loto ,creation d'equipes, match,etc...)
a savoir faire un tirage au sort dans un array ,une plage ,etc...

Je voulais partager une expérience concrète sur le mélange de tableaux en VBA, avec benchs et analyses détaillées,
qui, à mon avis, casse un mythe persistant autour de Fisher-Yates.

Contexte
On sait tous que l’algorithme de Fisher-Yates est présenté comme la référence absolue pour mélanger un tableau,
Et surtout!! avec la promesse que chaque élément a exactement la même chance d’être tiré.


Mais… cette promesse repose sur deux conditions essentielles :
  1. un générateur pseudo-aléatoire uniforme parfait
  2. un langage capable de gérer correctement les opérations bitwise et les overflows (C/C++ par exemple)

Or en VBA, on utilise généralement Rnd :
  1. pas uniformément parfait
  2. état interne caché et corrélé
  3. relativement lent

Donc, dans pratique en VBA , la garantie théorique n’est plus respectée.

Les algorithmes testés

Jai comparé trois méthodes pour mélanger des tableaux :

Méthode 1 : Mélange partiel de 1 à pivot central avec ( Rnd sur tout le tableau)
calcul de l'index de l'items interverti avec l'index de boucle: b = Rnd * (tl - 1) + 1

Méthode 2 : Mélange partiel de 1 à pivot central avec ( Rnd sur la section restante)
calcul de l'index de l'items interverti avec l'index de boucle : b = a + (Rnd * (tl - 1 - a))

Méthode 3 :le fisher-yates
Code:
Fisher-Yates classique

For i = UBound(arr) To LBound(arr) + 1 Step -1

    j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr))

    'ici on swicth  arr(i) et arr(j)

Next

3 Résultats mesurés Algorithme / Temps
nb:il peut arriver quelques fois ou c'est la méthode 1 qui l'emporte

Sur 40 éléments
  • Mélange1 23 µs
  • Mélange2 24 µs
  • Fisher-Yates 28 µs
Sur 50 000 éléments
  • Mélange1 7,68 ms
  • Mélange2 6,56 ms
  • Fisher-Yates 15 ms

Analyse: et performance

Les méthodes 1 et 2
sont environ 2 fois plus rapides que Fisher-Yates sur 50 000 items ou un tableau plus petit ême 40 items
La méthode 2 est légèrement plus rapide que la méthode 1, malgré un calcul "Aparament !! plus lourd”.
Explication :​
la réduction de la plage de tirage (tl - 1 - a) diminue le coût interne de Rnd et la conversion implicite en Long dans VBA.​
et on atteint jamais plus qu'un calcul fois la plage de donnée entière / 2​
Qualité du mélange
Pour un usage pratique dans Excel (jeux, désordre visuel, tirages simples), mélanger la moitié du tableau suffit à casser l’ordre.​

La Méthode Fisher-Yates:
n’apporte aucun avantage perceptible ici, et sa “garantie mathématique d'uniformité ” n’est pas respectée à cause de Rnd.
Limites des portages C++​
Les techniques bitwise comme XorShift fonctionnent en C/C++ mais sont fragiles en VBA : overflow, type signé, zéro état → générateur mort.​
Essayer de remplacer Rnd par XorShift ou autres PRNG bas niveau ne vaut pas le coup dans Excel.​

Conclusion:
au final
Fisher-Yates :
référence théorique :mais dans les faits en vba avec Rnd il ne respecte pas sa ganrantie d'uniformité
en VBA avec Rnd = surdimensionné, plus lent

Méthode 2 (pivot + section restante)
Plus rapide, fiable et suffisante pour “foutre le chaos” dans un tableau de lbound à ubound
et se rapprocher au plus près (mais même marge de duplicité de tirage que fisher-yates) d'un pseudo tirage uniforme

Moralité :
En VBA, privilégiez la pragmatique et le chrono, pas les dogmes théoriques.
une , 1/2 boucle + Rnd restreint fait le même job que Fisher-Yates… mais beaucoup plus vite.
a partir de gros volumes: temps /2 et c'est exponentiel en montant dans le volume de donnée a mélanger

les petites sub qui m'ont permis de vérifier tout ça

la méthode 1

VB:
Sub algomelange()
    'patricktoulon
    Dim t, a&, b, memo, pivot&, tl
    Dim bench As New cBenchmark
    Randomize
    ReDim t(1 To counttableau, 1 To 1)
    tl = UBound(t)
    pivot = Int(UBound(t) / 2)
    'on compte que l'algo
    Debug.Print "test melange avec " & counttableau & "; items"
    bench.Start
    For a = 0 To pivot + 1
        b = Rnd * (tl - 1) + 1
        memo = t(a + 1, 1)
        t(a + 1, 1) = t(b, 1)
        t(b, 1) = memo
    Next
    bench.TrackByName " fin de melange"
    Cells(1, "b").Resize(UBound(t)) = t
   
End Sub

la méthode 2
VB:
Sub algomelange2()
    'patricktoulon
    Dim t, a&, b, memo, pivot&, tl
    Dim bench As New cBenchmark
    Randomize
    ReDim t(1 To counttableau, 1 To 1)
    tl = UBound(t)
    'on compte que l'algo
    Debug.Print "test melange2 avec " & counttableau & "; items"
    bench.Start
    For a = 1 To tl / 2
        b = a + (Rnd * (tl - 1 - a))
        memo = t(a + 1, 1)
        t(a + 1, 1) = t(b, 1)
        t(b, 1) = memo
    Next
    bench.TrackByName " fin de melange2"
    Cells(1, "b").Resize(UBound(t)) = t
   
End Sub

la méthode Fisher-Yates
VB:
Sub FisherYatesShuffle()
    ' Mélange un tableau 1D en place avec l'algorithme de Fisher-Yates
    Dim i As Long, j As Long
    Dim temp As Variant
    Dim arr
    Dim bench As New cBenchmark
    ReDim arr(1 To counttableau, 1 To 1)
    Debug.Print "test Fisher-yates avec " & counttableau & "; items"
    bench.Start
   
    Randomize ' Initialise le générateur de nombres aléatoires
   
    For i = UBound(arr) To LBound(arr) + 1 Step -1
        j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr)) ' indice aléatoire entre LBound et i
       
        ' échange arr(i) et arr(j)
        temp = arr(i, 1)
        arr(i, 1) = arr(j, 1)
        arr(j, 1) = temp
    Next i
    bench.TrackByName " fin de melange fisher-yates"
    Cells(1, "c").Resize(UBound(arr)) = arr
   
   
End Sub

les resultats du bench pour 40 items

Code:
test melange avec 40; items
IDnr  Name             Count  Sum of tics  Percentage  Time sum
0      fin de melange      1          229     100,00%     23 us
      TOTAL                1          229     100,00%     23 us

Total time recorded: 23 us

test melange2 avec 40; items
IDnr  Name              Count  Sum of tics  Percentage  Time sum
0      fin de melange2      1          242     100,00%     24 us
      TOTAL                 1          242     100,00%     24 us

Total time recorded: 24 us

test Fisher-yates avec 40; items
IDnr  Name                          Count  Sum of tics  Percentage  Time sum
0      fin de melange fisher-yates      1          278     100,00%     28 us
      TOTAL                             1          278     100,00%     28 us

Total time recorded: 28 us

les résultats du bench pour 50 000 items

Code:
test melange avec 50000; items
IDnr  Name             Count  Sum of tics  Percentage  Time sum
0      fin de melange      1       65 283     100,00%   6,53 ms
      TOTAL                1       65 283     100,00%   6,53 ms

Total time recorded: 6,53 ms

test melange2 avec 50000; items
IDnr  Name              Count  Sum of tics  Percentage  Time sum
0      fin de melange2      1       67 101     100,00%   6,71 ms
      TOTAL                 1       67 101     100,00%   6,71 ms

Total time recorded: 6,71 ms

test Fisher-yates avec 50000; items
IDnr  Name                          Count  Sum of tics  Percentage  Time sum
0      fin de melange fisher-yates      1      127 201     100,00%     13 ms
      TOTAL                             1      127 201     100,00%     13 ms

Total time recorded: 13 ms

Je dépose un fichier ici si vous voulez tester le module classe benchmark est inclut

Pardon de casser le le mythe 🤣 🤣

Patrick
 

Pièces jointes

bonjour Patrick,
démonstration très intéressante.

pour ta gouverne Rnd est un algorithme et ce n'est pas vraiment aléatoire. je te suggère d'y inclure une chose qui pour le coup n'est pas prévisible.
Code:
Randomize Timer
 
Bonjour Robert merci du retour
oui pour rnd je sais
par contre pour randomize timer ? c'est le timer qui m'échape

après effectivement ce que j'ai voulu démontrer ici surtout, c'est que la méthode de switch avec rnd dans l'algo de Fisher-yates détruit finalement et purement le mythe et les chiffres sont éloquents c'est du simple au double à partir d'un certains niveau de donnée à swapper
 
re
ok là encore le resultats est parlant
si on augmente la puissancede calcul de rnd avec timer
sur 50 000
la version 1 presque 2ms de plus
la version 2 reste plus stable, - de 40 µs de plus
ficher_yates reste plus stable mais reste 2 fois plus lourd que mes deux méthodes
VB:
test melange avec 50000; items avec randomize timer
IDnr  Name             Count  Sum of tics  Percentage  Time sum
0      fin de melange      1       79 870     100,00%   7,99 ms
      TOTAL                1       79 870     100,00%   7,99 ms

Total time recorded: 7,99 ms

test melange avec 50000; items sans randomize timer
IDnr  Name             Count  Sum of tics  Percentage  Time sum
0      fin de melange      1       64 516     100,00%   6,45 ms
      TOTAL                1       64 516     100,00%   6,45 ms

Total time recorded: 6,45 ms

test melange2 avec 50000; items avec randomize timer
IDnr  Name              Count  Sum of tics  Percentage  Time sum
0      fin de melange2      1       68 060     100,00%   6,81 ms
      TOTAL                 1       68 060     100,00%   6,81 ms

Total time recorded: 6,81 ms

test melange2 avec 50000; items sans randomize timer
IDnr  Name              Count  Sum of tics  Percentage  Time sum
0      fin de melange2      1       65 751     100,00%   6,58 ms
      TOTAL                 1       65 751     100,00%   6,58 ms

Total time recorded: 6,58 ms

test Fisher-yates avec 50000; items
IDnr  Name                          Count  Sum of tics  Percentage  Time sum
0      fin de melange fisher-yates      1      135 302     100,00%     14 ms
      TOTAL                             1      135 302     100,00%     14 ms

Total time recorded: 14 ms

test Fisher-yates avec 50000; items
IDnr  Name                          Count  Sum of tics  Percentage  Time sum
0      fin de melange fisher-yates      1      136 657     100,00%     14 ms
      TOTAL                             1      136 657     100,00%     14 ms

Total time recorded: 14 ms
d'ailleurs AttentionEn VBA avec le duplicateur de randomize sur des tableau de petites tailles, il serait contre produtif (vérifié)
avec randomize des doublons sortent plus souvent que sans randomize
 
Dernière édition:
bullshit, on doit faire le boucle jusqu'au bout, pas la moitié, éventuellement on peut utiliser "Sattolo" pour minimaliser la probabilité qu'aucun élément se trouvera sur la même position, mais à mon avis, cela n'est plus aléatoire senso stricto.
Voir PJ, colonne D. Avec la méthode "PT" on utilise la plage "A1:A50000" et on les colle "aleatoirement" dans la plage "C1:C50000", Mais (!!!) il y a ca. 15.000 éléments (30%) qui sont encore à leur position originale, tous à partir de la position 25.000, parce qu'on n'a traité que la moitié des élements.

PS. Est-ce qu'il y a une méthode pour 100 fois lancer la même macro et de mettre les données du benchmark dans une matrice/dictionaire/coller dans un TS pour comparer les résultats.

PS2. parce que le fichier était trop grand, j'ai supprimé les lignes à partir de 100. Donc il faut copier et coller la ligne 100 de 101 à 50.000 et puis ajouter des valeurs aléatoires de A1 à A50000. Oubien, on change la plages dans les 2 macros A1:A100 au lieu de A1:A50000
 

Pièces jointes

bonjour
non la 1/2 boucle suffit avec la methode 1 et 2
tu dis que x% des items pourrait ne pas être déplacés
c'est possible en effet MAIS de la même manière le fisher-yates pourrait choisir un item et le remettre à sa place donc kif kif

pour information
la méthode 2 même si on elneve le /2 elle reste plus rapide que la fisher-yates
donc ton argument est non recevable

le report dans un tableau du benchmark;
et non pas pour le moment pour un compte exacte les reports se font dans la console demandé au terminate des instances de classe benchmark
je travail sur la question j'avais déjà fait des trucs mais ca ne me plaisait pas
ps: pour info je ne sais pas ce que tu a foutu dans les code mais on passe a 60 ms environ pour 25 max tout à l'heure
donc a mon avis tu a faux sur toute la ligne
 
Dernière édition:
Bonsoir @patricktoulon

en passant par un tableau 1D

VB:
test Fisher-yates OK en vba 1D (Champion) avec 40; items
IDnr  Name                               Count  Sum of tics  Percentage  Time sum
0      Fisher-yates OK en vba 1D (Champion) 1     63          100,00%     6 us
               TOTAL                        1     63          100,00%     6 us

Total time recorded: 6 us
-------------------------------------------------

et

VB:
test Fisher-yates OK en vba 1D (Champion) avec 50000; items
IDnr  Name                               Count  Sum of tics  Percentage  Time sum
0      Fisher-yates OK en vba 1D (Champion) 1     29120       100,00%     2,91 ms
               TOTAL                        1     29120       100,00%     2,91 ms

Total time recorded: 2,91 ms
-------------------------------------------------
[B]
[/B]


le code VBA ci-dessous :


VB:
Option Explicit
Public Chrono As String

' --- Déclaration des API Windows (Haute Précision) ---
' Ces fonctions interrogent l'horloge interne du processeur (Haute précision)
#If VBA7 Then
    Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#Else
    Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#End If

Sub AlgoTest()
    ' --- CONFIGURATION ---
    Dim NombreElements As Long
    NombreElements = 50000 ' 500 000 éléments
   
    ' --- DÉCLARATION ---
    Dim arr() As Long
    Dim i As Long, j As Long, temp As Long
    Dim Frequence As Currency          ' Fréquence du processeur
    Dim CompteurDepart As Currency     ' Heure de départ (Tics)
    Dim CompteurFin As Currency        ' Heure de fin (Tics)
    Dim Tics As Currency, Secondes As Double
    Dim NomAlgo As String
   
    ' 0. On récupère la fréquence du processeur (combien de tics par seconde)
    QueryPerformanceFrequency Frequence
   
    ' 1. Initialisation Tableau 1D (Rapide)
    ReDim arr(1 To NombreElements)
    For i = 1 To NombreElements
        arr(i) = i
    Next i
   
    ' 2. Bench du Fisher-Yates 1D
    NomAlgo = "Fisher-yates OK en vba 1D (Champion)"
   
    ' 2.1 Lancement du chrono (API Windows)
    QueryPerformanceCounter CompteurDepart
    Randomize
   
    ' Algo complet (Astuce Step)
    For i = NombreElements To 2 Step -1
        j = Int(Rnd * i) + 1
        temp = arr(i)
        arr(i) = arr(j)
        arr(j) = temp
    Next i
   
    ' 2.2 Arrêt du chrono (API Windows)
    QueryPerformanceCounter CompteurFin
   
    ' 2.3 Calcul du temps réel
    Tics = CompteurFin - CompteurDepart
    Secondes = Tics / Frequence
   
    ' 3. Affichage temps d'exécution
    Call AffichageTemps(NomAlgo, NombreElements, Secondes)
   
    ' 4. COLLER PAR DÉCOUPAGE (L'ASTUCE CONCRETE)
    Application.ScreenUpdating = False
    Call CollerParDecoupage(arr, "A1") ' On colle en A1
    Application.ScreenUpdating = True
   
    MsgBox "Terminé ! " & NombreElements & " lignes mélangées et collées en " & Chrono
End Sub

' --- FONCTION D'AFFICHAGE STYLE "cBenchmark" ---

Sub AffichageTemps(Nom As String, NbElements As Long, DureeSecondes As Double)
    Dim TicsAffichage As Long
    Dim ChaineTemps As String
    Dim Iterations As Long
    Dim MicroSecondes As Double
   
    ' Variables pour l'alignement
    Dim SeparateurNom As String
    Dim SeparateurTotal As String
    Dim SeparateurTics As String
   
    Iterations = 1 ' Une seule itération car on utilise l'API précise
   
    ' Calcul des Tics pour l'affichage (similaire à la classe originale)
    TicsAffichage = CLng(DureeSecondes * 10000000)
   
    ' Formatage du temps pour affichage humain
    If DureeSecondes >= 1 Then
        ' Si on dépasse 1 seconde
        ChaineTemps = Format(DureeSecondes, "0.00") & " s"
    ElseIf DureeSecondes > 0.001 Then
        ' Si on est entre 1ms et 1s
        ChaineTemps = Format(DureeSecondes * 1000, "0.00") & " ms"
    Else
        ' Si on est sous 1ms -> ON AFFICHE EN MICROSECONDES (us)
        MicroSecondes = DureeSecondes * 1000000
        ChaineTemps = Format(MicroSecondes, "0") & " us" ' Patrick affiche sans décimales pour les us
    End If
   
    Debug.Print "test " & Nom & " avec " & NbElements & "; items"
    Debug.Print "IDnr  Name                               Count  Sum of tics  Percentage  Time sum"
   
    ' --- CALCUL DES ESPACEMENTS ---
   
    ' 1. Pour le Nom de l'algo (Dynamique)
    If Len(Nom) > 25 Then SeparateurNom = " " Else SeparateurNom = Space(25 - Len(Nom))
   
    ' 2. Pour TOTAL (Fixe)
    If Len("TOTAL") > 25 Then SeparateurTotal = " " Else SeparateurTotal = Space(25 - Len("TOTAL"))
   
    ' 3. Pour les Tics (Dynamique selon la taille du chiffre)
    If Len(CStr(TicsAffichage)) > 12 Then SeparateurTics = " " Else SeparateurTics = Space(12 - Len(CStr(TicsAffichage)))

    ' --- LIGNE DE RÉSULTAT ---
    Debug.Print "0      " & Nom & SeparateurNom & _
                CStr(Iterations) & Space(6 - Len(CStr(Iterations))) & _
                TicsAffichage & SeparateurTics & _
                "100,00%     " & ChaineTemps
               
    ' --- LIGNE TOTAL ---
    Debug.Print "               TOTAL    " & SeparateurTotal & _
                CStr(Iterations) & Space(6 - Len(CStr(Iterations))) & _
                TicsAffichage & SeparateurTics & _
                "100,00%     " & ChaineTemps
               
    Debug.Print ""
    Debug.Print "Total time recorded: " & ChaineTemps
    Debug.Print "-------------------------------------------------"
    Chrono = ChaineTemps
End Sub

' --- L'ASTUCE : COLLER PAR DÉCOUPAGE (Évite le crash du Transpose > 65 000) ---
Sub CollerParDecoupage(TableauSource() As Long, AdresseDepart As String)
    Dim TaillePaquet As Long
    Dim TotalLignes As Long
    Dim r As Long
    Dim FinLigne As Long
    Dim TableauTemp() As Variant
    Dim ws As Worksheet
   
    Set ws = ActiveSheet
    TaillePaquet = 65000 ' Taille du paquet (sûr pour Excel)
    TotalLignes = UBound(TableauSource)
    r = 0 ' Offset (ligne de départ actuelle)
   
    Do While r < TotalLignes
        ' Calcul de la fin du paquet actuel
        FinLigne = r + TaillePaquet
        If FinLigne > TotalLignes Then FinLigne = TotalLignes
       
        ' Création d'un tableau temporaire 2D pour le collage (Excel aime le 2D)
        Dim PaquetEnCours As Long
        PaquetEnCours = FinLigne - r
        ReDim TableauTemp(1 To PaquetEnCours, 1 To 1)
       
        ' Remplissage du paquet depuis le tableau 1D source
        Dim k As Long
        For k = 1 To PaquetEnCours
            TableauTemp(k, 1) = TableauSource(r + k)
        Next k
       
        ' Collage effectif dans la feuille
        ws.Range(AdresseDepart).Offset(r, 0).Resize(PaquetEnCours, 1).Value = TableauTemp
       
        ' Avancement dans le tableau source
        r = FinLigne
       
        ' Petite pause pour laisser respirer Excel
        DoEvents
    Loop
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour