Tirage au sort avec Conditions

[Pierre77]

Bonjour à tous,

J'ai réalisé un tirage au sort avec conditions.

Pour résume, cette macro est utilisé lors de tournois. Les joueurs participent a une 1er phase où ils jouent en poules. De ces Poules sortent 8 joueurs. Je me retrouve alors avec 32 joueurs dans le tableau final.
Les 4 joueurs coté Gagnant de chaque Poules sont placé directement dans ce Tableau Final et les 4 joueurs coté Perdant de chaque Poules subissent un Tirage au sort pour avoir leurs places dans le Tableau Final.

Les conditions sont les suivante, les joueurs du cote Perdant ne doivent pas rencontrer un joueurs du Cote Gagnant de leurs poules.

Je vous joins un fichier d'exemple pour plus de compréhension.

Ma macro fonctionne mais je voudrais savoir si vous auriez une solution pour réduire le temps d’exécution, car celle-ci va être exécuté lors du Tournoi.
Lors de mes essaies, il m'est arrivé qu'elle mette 5 / 10 mns pour s’exécuter, voir même parfois se bloquer.

Merci d'avance pour votre aide

Pierre

 

[Caillou]

Re : Tirage au sort avec Conditions

Bonjour,

Tu peux déjà rajouter ces 2 lignes de code au début de ta procédure

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

pour désactiver le rafraichissement écran et le calcul automatique
Cela ne pourra qu'être bénéfique.

Caillou

 

[Pierre77]

Re : Tirage au sort avec Conditions

Bonjour Caillou,

Si je mets ces lignes en début de ma macro, est ce que le rafraîchissement d’écran et le calcul automatique se remettrons normalement en fin d’exécution ou faut il aussi que je rajoute les code correspondant en fin ?

Merci pour ce début d'indice

 

[Caillou]

Re : Tirage au sort avec Conditions

Re,

Oui effectivement c'est mieux de rajouter à la fin :

Application.ScreenUpdating = True
Application.Calculation=xlCalculationAutomatic

Caillou

 

[ROGER2327]

Re : Tirage au sort avec Conditions

Bonjour à tous.

Une proposition à tester dans le classeur joint.​

Public Sub tirage_Perdant()
'
'|¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯|
'| Ajouter la référence à la bibliothèque |
'|      Microsoft Scripting Runtime       |
'|        (scrrun.dll) au projet !        |
'|________________________________________|
'
Dim i&, j&, k&, l&, m&, r!, x, p(15), z(), q As New Scripting.Dictionary
  Randomize
  k = 100
  z = Array(Array(1, 4), Array(5, 8), Array(9, 12), Array(13, 16))

  Do
    k = k - 1
    For i = 1 To 16: q.Add i, i: Next
    For m = 0 To 3
      l = 0
      For i = 1 To 16
        If q.Exists(i) Then
          Select Case q(i)
          Case Is < z(m)(0): p(l) = q(i): l = l + 1
          Case Is > z(m)(1): p(l) = q(i): l = l + 1
          End Select
        End If
      Next
      For i = 0 To l - 1
        r = Rnd: x = p(i): p(i) = p(i + Int((l - i) * r)): p(i + Int((l - i) * r)) = x
      Next
      On Error Resume Next
      For i = 0 To 3: q.Remove p(i): Next
      On Error GoTo 0
      For i = 0 To 3: x = p(0): For j = 0 To 14: p(j) = p(j + 1): Next: p(15) = x: Next
    Next m
    Set q = Nothing
  Loop While l < 4 And -1 < k

  Feuil11.[J1:J16].Value = WorksheetFunction.Transpose(p)
End Sub

Bonne nuit.


ℝOGER2327
#7536

Jeudi 26 Phalle 141 (Disparition de l’Ancien Breughel, incendiaire - fête Suprême Quarte)
19 Fructidor An CCXXII, 9,6077h - tagète
2014-W36-5T23:03:31Z

 

[KenDev]

Re : Tirage au sort avec Conditions

Bonjour Pierre, Roger, Caillou

Une autre possibilité avec le code ci dessous qui ne nécessite pas l'activation d'une bibliothèque. Environ 5 ms pour les 2 codes d'après mon ordi. L'affichage a été copié sans vergogne sur mon petit camarade. Cordialement

KD

Sub Test()
    Dim a%, b%, c%, d%
    ReDim e%(1 To 16)
    Randomize
LineS:
    a = 0: ReDim f%(1 To 16)
    Do
        a = a + 1: b = Int(a / 4) + 1 + (a Mod 4 = 0): d = 0
        Do
            d = d + 1
            If d = (17 - a) * 3 + 1 Then GoTo LineS
            c = Int(12 * Rnd) + 1: c = c - 4 * (c > 4 * (b - 1))
        Loop Until f(c) = 0
        e(a) = c: f(c) = 1
    Loop Until a = 16
    Range(Cells(1, 10), Cells(16, 10)).Value = WorksheetFunction.Transpose(e)
End Sub

Edit : suppression variable i% inutilisée

 

[ROGER2327]

Re : Tirage au sort avec Conditions

Suite...

(...)
Une autre possibilité avec le code ci dessous qui ne nécessite pas l'activation d'une bibliothèque. Environ 5 ms pour les 2 codes d'après mon ordi. (...)

On obtient effectivement des résultats semblables en des temps voisins par des moyens très-différents.
Je viens de regarder de près les deux propositions. Je constate d'abord que le temps d'exécution des calculs est négligeable devant le temps d'affichage.
Exécuté 10 000 fois, mon code prends environ 9 s. Cette durée est réduite à 1s en inhibant la ligne d'affichage​

  Feuil11.[J1:J16].Value = WorksheetFunction.Transpose(p)

Constatation analogue avec le code de KenDev.

J'ai donc procédé à la comparaison du temps de calcul, sans affichage du résultat.
J'ai effectué 10 000 000 (dix millions) d'exécutions des codes. J'obtiens une durée d'exécution moyenne de 106,4 μs pour mon code, contre 99,8 μs pour celui de KenDev.

Compte tenu de la rapidité intrinsèque des opérations mises en œuvre et de la concision du code de KenDev comparés à la lenteur de certaines fonctions de dictionnaire (comme Remove), je m'attendais à ce que l'avantage de rapidité fût plus nette en faveur du code de KenDev.

J'ai donc repris l'analyse en étudiant la fréquence de recours à la fonction Rnd.
Toujours sur 10 000 000 d'exécutions, j'ai relevé

• le nombre maximum d'appel de la fonction Rnd par exécution ;
• le nombre moyen d'appel de la fonction Rnd par exécution.

Pour le code de KenDev, j'ai obtenu (a) 4 728 (b) 428,6855058.
Pour le mien, (a) 774 (b) 61,1249735.

J'ai ainsi compris pourquoi les codes s'exécutent en des temps comparables. Celui de KenDev est formellement plus simple que le mien, mais exécute en moyenne six fois plus de calculs. Ce qu'on gagne d'un côté se perd d'un autre...

Quant à décider de ce qui est préférable, je ne sais. Affaire de goût.

Dans la foulée, j'ai repris le code brut proposé plus haut.
Après nettoyage, je propose :​

Public Sub tirage_Perdant_1()
'
'|¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯|
'| Ajouter la référence à la bibliothèque |
'|      Microsoft Scripting Runtime       |
'|        (scrrun.dll) au projet !        |
'|________________________________________|
'
Dim i%, j%, k%, l%, m%, n%, o%, p, q%(11), r%(15), s As New Scripting.Dictionary

  Randomize
  For k = 25 To 1 Step -1
    For j = 1 To 16: s.Add j%, j%: Next
    For i = 0 To 3
      l = 0: m = 4 * i
      For Each p In s.Keys
        Select Case s(p)
        Case Is < m + 1: q(l) = s(p): l = l + 1
        Case Is > m + 4: q(l) = s(p): l = l + 1
        End Select
      Next p
      For j = 0 To l - 2: n = j + Int((l - j) * Rnd): o = q(j): q(j) = q(n): q(n) = o: Next
      On Error Resume Next
      For j = 0 To 3: r(m + j) = q(j): s.Remove q(j): Next
      On Error GoTo 0
    Next i
    Set s = Nothing
    If l > 3 Then Exit For
  Next k

  With Feuil11.[J1:J16]
  If k Then .Value = WorksheetFunction.Transpose(r) Else .ClearContents
  End With
End Sub

Avec les mêmes conditions d'expérience que ci-dessus, j'obtiens (a) 588, (b) 54,1873812 et une durée moyenne d'exécution réduite d'un bon tiers : 66,3 μs.​

Bonne nuit.


ℝOGER2327
#7538

Dimanche 1[SUP]er[/SUP] Absolu 142 (Nativité d’Alfred Jarry - fête Suprême Première première)
22 Fructidor An CCXXII, 0,6094h - noisette
2014-W37-1T01:27:45Z

 

[Pierre77]

Re : Tirage au sort avec Conditions

Bonjour à tous les 3

un énorme MERCI pour vos réponse et pour votre aide. Je vais tester ça tout de suite.
Roger, j'aurais juste une petite question:
Ce fichier va être utilisé par plusieurs personnes différente, est ce que chaque personne qui va l'utilisé va devoir ajouter la référence à la bibliothèque ?

Encore MERCI a vous
Pierre

 

[ROGER2327]

Re : Tirage au sort avec Conditions

Re...

(...) Je vais tester ça tout de suite.
(...)

Attention ! J'avais une faute dans le dernier code proposé : je viens de corriger.

​

(...)
Roger, j'aurais juste une petite question:
Ce fichier va être utilisé par plusieurs personnes différente, est ce que chaque personne qui va l'utilisé va devoir ajouter la référence à la bibliothèque ?
(...)

Oui !

Mais on peut se passer de cette bibliothèque en cas (improbale) qu'elle ne soit disponible partout, ou en cas (hélas plus probable) qu'un administrateur zélé interdise l'association de certaines bibliothèques au projet.
Il suffit de recourir non à un dictionnaire mais à une collection.

Voici le code :​

Public Sub tirage_Perdant_2()
'
'|¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯|
'|     Ne nécessite pas la bibliothèque     |
'| Microsoft Scripting Runtime (scrrun.dll) |
'|__________________________________________|
'
Dim i%, j%, k%, l%, m%, n%, o%, q%(11), r%(15), s As New Collection

  Randomize
  For k = 25 To 1 Step -1
    For j = 1 To 16: s.Add Item:=j%, Key:=CStr(j): Next
    For i = 0 To 3
      l = 0: m = 4 * i
      For j = 1 To s.Count
        Select Case s(j)
        Case Is < m + 1: q(l) = s(j): l = l + 1
        Case Is > m + 4: q(l) = s(j): l = l + 1
        End Select
      Next j
      For j = 0 To l - 2: n = j + Int((l - j) * Rnd): o = q(j): q(j) = q(n): q(n) = o: Next
      On Error Resume Next
      For j = 0 To 3: r(m + j) = q(j): s.Remove CStr(q(j)): Next
      On Error GoTo 0
    Next i
    Set s = Nothing
    If l > 3 Then Exit For
  Next k

  With Feuil11.[J1:J16]
  If k Then .Value = WorksheetFunction.Transpose(r) Else .ClearContents
  End With
End Sub

Les modifications apportées sont minimes, mais elles se payent : le temps moyen de calcul double (127,2 μs contre 66,3 μs). En pratique, ce n'est évidemment pas gênant.​

Bonne soirée.


ℝOGER2327
#7540

Dimanche 1[SUP]er[/SUP] Absolu 142 (Nativité d’Alfred Jarry - fête Suprême Première première)
22 Fructidor An CCXXII, 6,0706h - noisette
2014-W37-1T14:34:10Z

 

[Pierre77]

Re : Tirage au sort avec Conditions

Merci pour vos lignes de codes ca marche super bien dans mon tableau.

 

[KenDev]

Re : Tirage au sort avec Conditions

Bonsoir à tous,

Merci et bravo Roger pour vos commentaire éclairés. Fort de votre étude je me suis attaché à réduire le nombre d'appels à Rnd. J'ai procédé deux fois à 1 000 000 de tests :

Le nombre maximum d'appels passe de 4728 à environ 200 (131 puis 197). Le nombre moyen d'appels passe de 429 à 118.

Sans affichage j'obtiens (deux mesures en changeant l'orde des procédures testées) :
Roger n°2 : 60 puis 57 µs
KD n°2 : 33 puis 31 µs

Je ne doute pas que ce gain sera primordial pour une sub destinée à être lancée, je suppose, une poignée de fois par an...

Cordialement
KD

Sub TestKD3()
    Dim a%, b%, c%, d%, g%()
    ReDim e%(1 To 16)
    Randomize
LineS:
    a = 0: b = 0: ReDim f%(1 To 16)
    Do
        a = a + 1: b = b - (a Mod 4 = 1): ReDim g(1 To 12): d = 0
        Do
            c = Int(12 * Rnd) + 1
            If g(c) = 0 Then g(c) = 1: d = d + 1
            e(a) = c - 4 * (c > 4 * (b - 1))
        Loop Until f(e(a)) = 0 Or d = 12
        If d = 12 And Not (f(e(a)) = 0) Then GoTo LineS
        f(e(a)) = 1
    Loop Until a = 16
    Range(Cells(1, 10), Cells(16, 10)).Value = WorksheetFunction.Transpose(e)
End Sub

 

[ROGER2327]

Re : Tirage au sort avec Conditions

Re...

(...) je me suis attaché à réduire le nombre d'appels à Rnd. J'ai procédé deux fois à 1 000 000 de tests :

Le nombre maximum d'appels passe de 4728 à environ 200 (131 puis 197). Le nombre moyen d'appels passe de 429 à 118.

Sans affichage j'obtiens (deux mesures en changeant l'orde des procédures testées) :
Roger n°2 : 60 puis 57 µs
KD n°2 : 33 puis 31 µs

Joli !

​

(...)
Je ne doute pas que ce gain sera primordial pour une sub destinée à être lancée, je suppose, une poignée de fois par an...
(...)

Certes. Ne sommes-nous pas des artisans amoureux de la belle ouvrage à l'ancienne, élevée sous la mère et moulée à la louche selon la tradition séculaire de nos pères, grand-pères, arrière-grands pères et tutti quanti ?​

Bonne journée.

 

[pierrejean]

Re : Tirage au sort avec Conditions

Bonjour à tous

Juste pour signaler que l'on peut aussi se passer de la bibliothèque Microsoft Scripting Runtime (scrrun.dll)
Avec:

Set s = CreateObject("Scripting.dictionary")

Et bien sur un grand BRAVO à Kendev et Roger pour ces superbes codes

 

[ROGER2327]

Re : Tirage au sort avec Conditions

Bonjour à tous, bonjour pierrejean.

(...)
Juste pour signaler que l'on peut aussi se passer de la bibliothèque Microsoft Scripting Runtime (scrrun.dll)
Avec:

Set s = CreateObject("Scripting.dictionary")

(...)

D'accord !
Mais :

1. Le fait que la bibliothèque ne soit pas explicitement référencée dans le projet n'empêche pas que la déclaration Set s = CreateObject("Scripting.dictionary") fasse implicitement appel à cette bibliothèque. Donc, si notre ami n'est pas certain que tous les postes où doit être déployé le code peuvent accéder à la bibliothèque[SUP](1)[/SUP], le problème persiste.
2. Le code obtenu est beaucoup plus lent que si on ajoute la référence au projet. En pratique, ce n'est pas bien grave car, pour paraphraser KenDev :

   Je ne doute pas que cette perte sera primordiale pour une sub destinée à être lancée, je suppose, une poignée de fois par an...

Voici le code :
​

Public Sub tirage_Perdant_3()
'
'|¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯|
'|         Utilise la bibliothèque          |
'| Microsoft Scripting Runtime (scrrun.dll) |
'|     sans qu'il soit nécessaire de la     |
'|        réferencer explicitement.         |
'|__________________________________________|
'
Dim i%, j%, k%, l%, m%, n%, o%, p, q%(11), r%(15), s As Object

  Randomize
  Set s = CreateObject("Scripting.Dictionary")
  For k = 25 To 1 Step -1
    For j = 1 To 16: s.Add j%, j%: Next
    For i = 0 To 3
      l = 0: m = 4 * i
      For Each p In s.Keys
        Select Case s(p)
        Case Is < m + 1: q(l) = s(p): l = l + 1
        Case Is > m + 4: q(l) = s(p): l = l + 1
        End Select
      Next p
      For j = 0 To l - 2: n = j + Int((l - j) * Rnd): o = q(j): q(j) = q(n): q(n) = o: Next
      On Error Resume Next
      For j = 0 To 3: r(m + j) = q(j): s.Remove q(j): Next
      On Error GoTo 0
    Next i
    s.RemoveAll
    If l > 3 Then Exit For
  Next k

  With Feuil11.[J1:J16]
  If k Then .Value = WorksheetFunction.Transpose(r) Else .ClearContents
  End With
End Sub

(...)
Et bien sur un grand BRAVO à Kendev et Roger pour ces superbes codes

Merci pour le compliment.​

Bonne soirée.

___________
[SUP](1)[/SUP]...ce qui m'étonnerait vraiment.


ℝOGER2327
#7542

Lundi 2 Absolu 142 (Saint Ptyx, silentiare (Abolition de) - fête Suprême Quarte)
23 Fructidor An CCXXII, 5,8563h - houblon
2014-W37-2T14:03:18Z