tirage aléatoire

[Crespo]

Bonjour,

Je souhaiterais effectuer un tirage sans double avec des critères.

Ci-joint le fichier avec un exemple.

La colonne A peut être "flexible" avec moins ou plus d'éléments

Merci pour votre aide

 

[job75]

Bonsoir Crespo, bienvenue sur XLD,

Voyez le fichier joint et cette formule matricielle en D2 :

=INDEX($A:$A;EQUIV(MAX(SI(GAUCHE(Tableau1[Listes des Equipes])=DROITE(D1);Tableau1[ALEA]));$B:$B;0))

à valider par Ctrl+Maj+Entrée et tirer vers la droite.

Touche F9 pour un nouveau tirage.

A+

 

[Crespo]

Merci pour fichier, par contre je ne peux pas tirer la formuler la formule

 

[Dranreb]

Bonsoir.
Un essai en VBA

 

[job75]

Merci pour fichier, par contre je ne peux pas tirer la formuler la formule

Vous avez parlé d'un tirage aléatoire.

Mais bon si vous voulez tirer la formule vers le bas entrez en D2, toujours en matriciel :

=SIERREUR(INDEX($A:$A;EQUIV(GRANDE.VALEUR(SI(GAUCHE(Tableau1[Listes des Equipes])=DROITE(D$1);Tableau1[ALEA]);LIGNE()-1);$B:$B;0));"")

Bonsoir Bernard.

 

[Dranreb]

Bonsoir job75
En effet mais il a aussi parlé de tirage sans doublon, ce qui y impliquait plusieurs éléments.

 

[mapomme]

Bonsoir Crespo, bienvenue sur XLD,

Voyez le fichier joint et cette formule matricielle en D2 :

=INDEX($A:$A;EQUIV(MAX(SI(GAUCHE(Tableau1[Listes des Equipes])=DROITE(D1);Tableau1[ALEA]));$B:$B;0))

à valider par Ctrl+Maj+Entrée et tirer vers la droite.

Touche F9 pour un nouveau tirage.

A+

Bonjour @job75 ,

Sur mon Excel 365, quand on tire la formule de D2 en E2, on obtient un résultat incohérent.
Et si on continue de tirer jusqu'en F2, la formule redevient correcte!

C'est, me semble-t-il, est la conséquence de la fameuse incohérence d'Excel concernant les références absolues versus références relatives dans les tableaux structurés qu' Excel gère de manière totalement illogique et imbécile (à mon sens).

D'autant plus que si au lieu de tirer la formule, on la copie (copier puis coller formule) depuis D2 sur la plage E2:F2, la formule est bien recopiée.

Qu'en est-il pour toi @job75 ?

nota : quand on tire la formule jusqu'en F2, la formule redevient correcte => il semblerait qu'Excel fasse une permutation circulaire sur les colonnes du tableau structuré (avec deux colonnes pour le tableau strcturé, on revient à la formule initiale pour la colonne F).


Un peu de littérature ICI.

 

[Efgé]

Bonjour à tous
@mapomme
Et avec cette modification de la proposition de @job75 (que je salut), le problème est toujours là quand tu Tire la formule ?

=SIERREUR(INDEX($A:$A;EQUIV(GRANDE.VALEUR(SI(GAUCHE(Tableau1[[Listes des Equipes]:[Listes des Equipes]])=DROITE(D$1);Tableau1[[ALEA]:[ALEA]]);LIGNE()-1);$B:$B;0));"")

Cordialement

 

[job75]

Bonjour mapomme, Efgé, le forum,

Puisque MS vous ennuie avec ses tableaux structurés ne les utilisez pas et voyez les noms définis Equipes et ALEA pour cette formule en D2 :

=SIERREUR(INDEX($A:$A;EQUIV(GRANDE.VALEUR(SI(GAUCHE(Equipes)=DROITE(D$1);ALEA);LIGNE()-1);$B:$B;0));"")

A+

 

[job75]

Après celle de Bernard voici ma solution VBA, elle utilise la macro bien connue Quick sort :

Sub Tirages()
Dim tablo, dest As Range, ncol%, col%, crit$, a(), b(), n&, i&
tablo = [Tableau1].Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
Set dest = [C1]
ncol = 3
Randomize
For col = 1 To ncol
    crit = Right(dest(1, col), 1)
    Erase a: Erase b 'RAZ
    n = 0
    For i = 1 To UBound(tablo)
        If Left(tablo(i, 1), 1) = crit Then
            ReDim Preserve a(n): a(n) = Rnd 'nombre aléatoire
            ReDim Preserve b(n): b(n) = tablo(i, 1)
            n = n + 1
        End If
    Next i
    If n Then tri a, b, 0, n - 1
    '---restitution---
    With dest(2, col)
        If n Then .Resize(n) = Application.Transpose(b) 'Transpose est limitée à 65536 lignes
        .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
    End With
Next col
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub

Si les résultats font plus de 65536 lignes il faudra un code pour transposer.

 

[job75]

J'ai comparé les durées d'exécution, chez moi sur Win 11 Excel 2019 :

- fichier du post #9 => 1,1 milliseconde

- fichier du post #10 => 5,7 millisecondes.

 

[job75]

J'ai aussi testé la macro de Bernard post #4 avec les tableaux des résultats complets.

Elle s'exécute en 0,72 milliseconde, c'est vraiment bien mieux.

 

[mapomme]

Bonjour @Efgé ,

Bonjour à tous
@mapomme
Et avec cette modification de la proposition de @job75 (que je salut), le problème est toujours là quand tu Tire la formule ?

=SIERREUR(INDEX($A:$A;EQUIV(GRANDE.VALEUR(SI(GAUCHE(Tableau1[[Listes des Equipes]:[Listes des Equipes]])=DROITE(D$1);Tableau1[[ALEA]:[ALEA]]);LIGNE()-1);$B:$B;0));"")

Cordialement

Pas testé mais ça doit marcher puisque tu passes en écriture "référence absolue" au niveau des champs du tableau structuré.
Mais il faut bien avouer que cela fait des formules longues comme le bras pour pas grand chose.

Autant revenir à une écriture classique du type proposé par @job75 dans le message #9.

Voire se passer des noms définis et faire :

=SIERREUR(INDEX($A:$A;EQUIV(GRANDE.VALEUR(SI(GAUCHE($A$1:$A$999)=DROITE(D$1);$B$1:$B$999);LIGNE()-1);$B:$B;0));"")

 

[job75]

Un peu dépité des performances de ma macro du post #10 j'en ai cherché une meilleure, la voici :

Sub Tirages()
Dim dest As Range, ncol%, col%, crit$, n, a(), i&, b
Set dest = [C1]
ncol = 3
Application.ScreenUpdating = False
dest(2).Resize(Rows.Count - dest.Row, ncol).ClearContents 'RAZ
Randomize
With [Tableau1].ListObject.Range 'tableau structuré
    .Sort .Columns(1), xlAscending, Header:=xlYes 'tri du tableau
    For col = 1 To ncol
        crit = Right(dest(1, col), 1) & "*"
        n = Application.CountIf(.Columns(1), crit)
        If n Then
            ReDim a(1 To n)
            For i = 1 To n: a(i) = Rnd: Next i 'nombres aléatoires
            b = .Cells(Application.Match(crit, .Columns(1), 0), 1).Resize(n, 2) 'au moins 2 éléments
            tri a, b, 1, n
            dest(2, col).Resize(n) = b 'restitution
        End If
    Next col
End With
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g, 1): b(g, 1) = b(d, 1): b(d, 1) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub

Elle s'exécute en 1,1 milliseconde et en 0,6 milliseconde si l'on enlève le tri initial du tableau.

Edit : oublié Randomize...

 

[bsalv]

bonjour,
milliseconde ou seconde ???

ce code fonctionne en "millisecondes"

Sub tirageBS()
     Dim aA, aB, aC, Ptr(1 To 3), t0, t1, t2, i, j, s, r
     t0 = Timer
     aA = Range("tableau1").Value
     ReDim aB(1 To UBound(aA), 1 To 3)
     For i = 1 To UBound(aA)
          s = UCase(Left(aA(i, 1), 1))
          Select Case s
               Case "A", "B", "C"
                    j = Asc(s) - 64
                    Ptr(j) = Ptr(j) + 1
                    aB(Ptr(j), j) = aA(i, 1)
          End Select
     Next

     ReDim aC(1 To Application.Max(Ptr), 1 To 3)
     For j = 1 To 3
          For i = Ptr(j) To 1 Step -1
               r = WorksheetFunction.RandBetween(1, i)
               aC(i, j) = aB(r, j)
               aB(r, j) = aB(i, j)
          Next
     Next
     t1 = Timer
    
     Range("C2").Resize(UBound(aC), UBound(aC, 2)).Value = aC
     t2 = Timer
    
     MsgBox "triage  : " & Format(t1 - t0, "0.000\s") & vbLf & "Collage : " & Format(t2 - t1, "0.000\s") & vbLf & "Total : " & Format(t2 - t0, "0.000\s")
End Sub