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.
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 ?
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
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
VB:
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
(...)
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
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 :
VB:
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
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 ?
(...)
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 ?
(...)
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 :
VB:
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
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
VB:
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
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 ?
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.
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...
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