XL 2021 tirage au sort aléatoire sans doublon

[aubaluc]

bonjour
je me penche vers vous car je sèche sur un problème que je vais essayer de vous expliquer clairement
je souhaite effectuer un tirage au sort de 2 tours avec 40 équipes maximum ( le nombre peut être différent )
il faut que dans les 2 tirages il n'y ait pas de doublon c'est à dire que dans chaque match 2 équipes ne se rencontrent pas
j'ai essayé avec la formule ALEA mais je ne suis pas certain de ne pas avoir de doublon
je pense qu'avec une macro se serai plus certain
je vous mets en pièce jointe l'exemple
merci d'avance à celles ou ceux qui voudront bien me dépanner
aubaluc

 

[Dranreb]

Les boucles dans Tirage1vs1OK ne sont que des initialisations.
Le plus gros du traitement est fait par la RencTrouvée qui s'auto-appelle récursivement après chaque paire formée pour établir le reste du tirage. Cette paire est en effet présumée provisoire du fait qu'elle peut empêcher l'appel récursif de trouver la suite s'il ne reste par exemple que 2 dernier joueurs et qu'il se sont déjà rencontrés lors d'une manche précédente.

 

[aubaluc]

bonjour
je me penche vers vous car je sèche sur un problème que je vais essayer de vous expliquer clairement
je souhaite effectuer un tirage au sort de 2 tours avec 40 équipes maximum ( le nombre peut être différent )
il faut que dans les 2 tirages il n'y ait pas de doublon c'est à dire que dans chaque match 2 équipes ne se rencontrent pas
j'ai essayé avec la formule ALEA mais je ne suis pas certain de ne pas avoir de doublon
je pense qu'avec une macro se serai plus certain
je vous mets en pièce jointe l'exemple
merci d'avance à celles ou ceux qui voudront bien me dépanner
aubaluc

Rebonjour,
merci beaucoup pour votre réponse rapide
il y a un problème , j'ai spécifié que le nombre d'équipes pouvait être différent , cela va de 8 à 40 équipes
votre réponse donne un tirage avec 40 équipes même si il y a 24 équipes donc problème
le nombre d'équipe est déterminé dans la colonne B à l'inscription des noms
aubaluc

 

[Dranreb]

@aubaluc, bonsoir.
Il aurait mieux valu mettre les plages sous forme de tableaux. En attendant la solution que j'ai proposée prend comme nombre d'équipes le nombre de lignes renseignées en colonne A à partir de la A3
Pour prendre plutôt la colonne B, mettez dans la macro Tirages :

' Récupération des inscrits
   TDon = WshT1.[A3:B3].Resize(WshT1.Cells(2 ^ 20, "B").End(xlUp).Row - 2).Value

Et effacez les lignes en trop dans la seconde feuille.

 

[Dranreb]

Bonjour.
Avec les plages mises sous forme de tableaux.

 

[aubaluc]

Bonjour.
Avec les plages mises sous forme de tableaux.

parfait un grand merci

 

[patricktoulon]

bonjour à tous les deux
@Dranreb
ça me titillait tes résultats de chrono
je me permet donc de te signaler une dernière fois que ton timer est largement faux
pour le coup je l'ai refait avec tes api dans un module chrono
j'ai même fait une sub de test pour voir si c'etait pas elles qui cafouillaent chez moi
les appels sont encadrés dans la sub tirages comme dans la sub de test
dans cette capture tu dis avoir fait 1.47 µs alors qu'en fait tu fait plus de 160 ms

et là pour le coup maintenant tu peux plus me contredire , j'utilise les même outils que toi

 

[Dranreb]

Encore une fois, je ne chronométrai pas la durée de l'ensemble du traitement, seulement la Function Tirage1vs1OK, le processus de tirage. La récupération des noms d'inscrits et la mise en forme des résultats je m'en fiche complètement. C'est suffisamment rapide pour l'utilisateur, d'une durée à peu près constante, ça ne risque jamais de s'embarquer dans une durée imprévisible. Tandis que la Tirage1vs1OK à elle seule pourrait en théorie s'envoler vers une durée de plusieurs minutes voire plus si, dans de nombreuses manches, on imposait la contrainte de ne pas opposer des joueurs appartenant à un même club … Dans mon ListeAléat.xlsm il y a le système des Postes à 2 qui a un algorithme très semblabe mais avec une sévère contrainte supplémentaire qui peut, lui, quoiqu'assez rarement mouliner pendant si longtemps qu'on peut préférer l'interrompre en fermant par la croix l'UFmVisu (au bout de quelques minutes il affiche un bandeau marron conseillant de le faire) puis lancer un autre tirage.

 

[patricktoulon]

ben c'est ce que fait tirage entre rouetourne et rouefixe avant la retranscription car c'est tirages qui commande
j'ai delpacé le calcul et message avant la retranscription de tresu
ton resultat n'est pas cohérent quand même

le end du moulin c'est quand tresu est prêt cest pas ailleurs
si tu veux être precis

Sub Tirages()
   Dim TDon(), TNoms() As String, TRésu(), M As Long, L As Integer, C As Integer, LMax As Long, MMax As Long, J As Long, LOt As ListObject
 '---------------------------------------------
 Dim tStart As Currency, tEnd As Currency, freq As Currency, Delta
'----------------------------------------------
' Récupération des inscrits
   Set LOt = [TbTour1].ListObject
   If PreserverAncienTirage(LOt, Action:="un autre tirage", Source:="Tirages") Then Exit Sub
    
    '---------------------------------------------
 'init perf counter
    QueryPerformanceFrequency freq
    QueryPerformanceCounter tStart
   '---------------------------------------------

   ImageRoueTourne
   TDon = LOt.DataBodyRange.Value
   ReDim TNoms(1 To UBound(TDon, 1))
   For L = 1 To UBound(TDon, 1)
      TNoms(L) = TDon(L, 2)
      If TNoms(L) = "" Then
         If MsgBox("Nom de l'équipe " & L & " manquant." _
            & vbLf & "Faut-il poursuivre en ignorant les données à partir de là ?", _
            vbYesNo, "Tirages") = vbYes Then
            ReDim Preserve TNoms(1 To L - 1): Exit For
         Else: Exit Sub: End If
         End If
      Next L
' Tirage
   If Tirage1vs1OK(NbJrs:=UBound(TNoms), Manches:=2) Then
   Rem. ——— Versement du tableau Tirage vers les tableaux Excel
      MMax = UBound(Tirage, 1) ' Nombre de tours
      LMax = UBound(Tirage, 2) ' Nombre de lignes de rencontres.
      ReDim TRésu(1 To LMax * 2, 1 To 2)
      For M = 1 To MMax
         For L = 1 To LMax
            For C = 1 To 2
               J = Tirage(M, L, C)
               If J <> 0 Then
                  TRésu(2 * (L - 1) + C, 1) = J: TRésu(2 * (L - 1) + C, 2) = TNoms(J)
               Else
                  TRésu(2 * (L - 1) + C, 1) = Empty: TRésu(2 * (L - 1) + C, 2) = Empty
                  End If: Next C, L
       'ici normalement on a fini la matrice vba du tableau
  'on capture avant retranscription
  '-----------------------------------------------------------------------
    QueryPerformanceCounter tEnd
    Delta = (tEnd - tStart) / freq ' secondes
   MsgBox "Temps d'execution: " & _
                      Format$(Delta, "0.000000000") & " sec" & vbCrLf & _
                      Format$(Delta * 1000, "0.000000") & " millisecondes" & vbCrLf & _
                      Format$(Delta * 1000000, "0.000") & " microsecondes" & vbCrLf & _
                      Format$(Delta * 1000000000, "#0") & " nanosecondes"

  '-----------------------------------------------------------------------
   Set LOt = Evaluate("TbTour" & M).ListObject
         If LOt.ListRows.Count > 0 Then LOt.DataBodyRange.Delete xlShiftUp
         LOt.HeaderRowRange.Offset(1).Resize(UBound(TRésu, 1), 2) = TRésu
         L = LOt.HeaderRowRange.Row
         LOt.ListColumns(3).DataBodyRange.Formula = "=IF(MOD(ROW()-" & L & ",2),(ROW()-" & L - 1 & ")/2,"""")"
         Next M
      End If
     ImageRoueFixe
   ActiveSheet.[A1].Select
   End Sub

à cet endroit là on a juste le temps que met toute ta mécanique pour fournir tresu et c'est tout
on est loin de ton resultat
d'ailleurs y a qu'a observer les deux captures tout a l'heure ton moteur me dit 1.47µs pour tout y compris la retranscription sur feuille
alors que l'on était a plus de 160ms et maintenant il me dit 111µs alors que l'on est a un peu plus de 22ms
même si on prends en compte le caractère aleatoire de le chose il est impossible que ce soit exacte
apres si tu teste juste la monté et descente d'un cylindre sur 4 c'est sur moi aussi je fait presque rien
le but c'est bien d'avoir une mesure au plus proche de la réalité non ?
c'est carrément incohérent (1.47µs pour 160ms )et (111µs pour 22ms) tu vois bien qu'il y a quelque chose qui tourne pas rond là non?
si encore il donnait un peu moins ou un peu plus tout le temps pareil ,je dirais oui c'est acceptable mais là on marche sur la tête
tu disais que l'on testait pas ben voila j'ai testé de long en large et tes chronos sont faux et même pire incohérents

 

[Dranreb]

Mets l'initialisation de départ juste devant la If Tirage1vs1OK(NbJrs:=UBound(TNoms), Manches:=2) Then et affiche le temps juste après son Then. Ça devrait être plus proche de la durée affichée par l'UFmVisu.

 

[Dranreb]

Par contre je viens de voir que si je place la QueryPerformanceCounter CycDépart en tête de la méthode DescConfig ça ajoute pas mal de temps mais qui ne fait pas partie du processus de tirage … Je suppose que c'est le Me.Show qui bouffe un peu …

 

[patricktoulon]

ha tiens donc
on va y arriver tu va finir par le mettre ou je l'ai mis car c'est là qu'il doit aller
mais reste qu'il est incohérent comme mes deux captures dans mes derniers messages le prouvent

tu ne peut le mettre ailleurs sans compromettre la véracité du résultat
essaie de remplacer ton fmvisu dans le code par des appels a cette fonction
met la dans un module

Option Explicit
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" ( _
                              ByRef lpPerformanceCount As Currency) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" ( _
                              ByRef lpFrequency As Currency) As Long

Dim Delta As Double
Function Timeelapsed(point, Optional mode As Double = 0)
    'patricktoulon
    Static tStart As Currency
    Static tEnd As Currency
    Static freq As Currency
    If point = 0 Or point = "start" Then
        tStart = 0
        tEnd = 0
        freq = 0
    End If
    
    Select Case LCase(point)
        Case 0, "start"
            'initialisation perf counter
            QueryPerformanceFrequency freq
            QueryPerformanceCounter tStart
            
        Case 1, "end"
            'capture du temps passé
            QueryPerformanceCounter tEnd
            Delta = (tEnd - tStart) / freq ' secondes
    End Select
    
    If point <> 0 And point <> "start" Then
        Select Case CStr(mode)
            Case "0", "s", "sec"
                Timeelapsed = Format$(Delta, "0.000000000") & " sec"
            Case "1", "ms", "milliS"
                Timeelapsed = Format$(Delta * 1000, "0.000000") & " millisecondes"
            Case "2", "µs", "microS"
                Timeelapsed = Format$(Delta * 1000000, "0.000") & " microsecondes"
            Case "3", "ns"
                Timeelapsed = Format$(Delta * 1000000000, "#0")
        End Select
    End If
End Function

Sub test()
   ' rien que ce test devrait t'ouvrir les yeux
   Dim i&
    Timeelapsed 0
    For i = 1 To 40
    Next
    MsgBox Timeelapsed(1, 2)
    
End Sub

 

[Dranreb]

Non, je tiens à ne mesurer autant que possible que le temps d'exécution de l'algorithme de tirage proprement dit.

 

[patricktoulon]

ok mais reste qu'il est faux
mon timelapsed donne 160ms et toi tu donne 1.47µs (pour tout ,)d'accords j'ai peut être tord
mais après tu donne 111µs et moi 22ms là je suis plus d'accords
tu comprends ?
a mon avis il doit y avoir une reinit quelque part dans tes fonction quand tu reajuste tes tableaux et le timer lui est arrêté
je vois que ca pour que cela soit aussi incohérent que ça

 

[Dranreb]

Ben cherche alors. Moi je ne vois pas ce qui pourrait déconner dans deux variables Private as Currency dans l'UserForm.
Essaie au plus près de chronométrer en parallèle dans des variables ailleurs mais aux mêmes checkpoints que moi: initalisation à la fin de la UFmVisu.DescConfig et arrêt au début de la UFmVisu.Conclure

 

[patricktoulon]

regarde ce que donne une simple boucle sur 40 sans rien faire

alors 1.47µs ou même 111 avec toute ta mécanique ,faut pas avoir fait l'ENA pour comprendre qu'il y a un soucis