modification pour tirage au sort 5 fois différents

**rocornet** · 12/11/2013, 17h01

Bonjour j'ai un code qui me permets de tirer au sort des données
Mais j'aimerais que ce code fasse 5 tirage et que aucune données
soit les mêmes au fur à mesure des tirages
(de façon 100% fiable)
Alors en resume
a chaque partie chaque "equipier" joue avec un autre equipier contre un autre duo d'equipier
Donc il faut tirer ces equipiers au sort mais a chaque aucun de ces equipiers ne doivent se retrouver dans les matchs d'après
juste une précision les coéquipiers de peuvent pas joué 2 fois un contre l'autre et ni 2 fois ensemble
Merci d'avance

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 Sub tirage_automatique()
 ReDim t(0)
 For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
 If cel.Value <> "" Then
 t(UBound(t)) = cel.Value
 ReDim Preserve t(UBound(t) + 1)
 End If
 Next
 ReDim Preserve t(UBound(t) - 1)
 Set dico = CreateObject("scripting.dictionary")
 Randomize
 While dico.Count < UBound(t) + 1
 x = Int((UBound(t) + 1) * Rnd)
 dico(x) = t(x)
 Wend
 Range("C2").Resize(UBound(t) + 1) = Application.Transpose(dico.items)
 End Sub

**Piixx_e** · 13/11/2013, 11h20

Bonjour !

Donc il faut tirer ces equipiers au sort mais a chaque aucun de ces equipiers ne doivent se retrouver dans les matchs d'après
juste une précision les coéquipiers de peuvent pas joué 2 fois un contre l'autre et ni 2 fois ensemble

Pour faire ça, il ne suffirait pas de placer un if quelque part ?

1) Tu fais ton 1er tirage d'équipiers
2) Tu recommences mais pour les 2e à 5e tirage, tu mets un if et une boucle qui lui dit "si une des équipes a déjà été faite, j'annule le tirage et je recommence, jusqu'à ce que j'ai une nouvelle équipe"

Bon le truc c'est que j'ai pas bien compris tes conditions, du coup ma condition if du 2) est pas très claire.
Quand tu dis qu'ils peuvent pas s'affronter deux fois, tu parles d'un joueur qui ne peut pas rejouer contre un autre joueur deux fois ? Vu qu'ils sont deux, il va te falloir pas mal d'équipes si je me trompe pas, mais dans ton excel il n'y en avait pas tant que ça il me semble.

Bref, en gros : s'il-te-plaît, essaye d'être plus clair dans les conditions sinon ça va être compliqué de t'aider

**rocornet** · 13/11/2013, 18h07

Alors en faite :
il faut que deux personnes ne se retrouvent pas dans la même équipe pendant les 5 matchs
et que 2 équipe ne se retrouvent pas deux fois

Exemple:

Pierre avec Luc contre Jean avec Marcel

Conditions:
-Pierre et Luc doivent jouer une seul fois ensemble idem pour jean et marcel
Pierre avec Luc ne doivent pas jouer deux fois contre Jean et Marcel
OK?
Merci d'avance

**Piixx_e** · 13/11/2013, 18h46

Mais alors il n'y a qu'une condition, puisqu'à partir du moment où Jean et Marcel ne peuvent plus jouer ensemble, ils ne peuvent pas rejouer contre Pierre et Luc. Du moins c'est ce que je comprends ?

**mercatog** · 14/11/2013, 20h53

Bonjour
Pour répondre à tes conditions il te faut 4^5 participants (soit 1024). toi de faire les calculs (En général pour Nb parties, il faudra 4^Nb participants).

Pour ce, je suppose que la condition 4^Nb est vérifiée.
Le nom des participants se trouve en feuille Feuil1 dans la plage A2:Axx
Les Nb manche tirés aléatoirement se trouveront dans la feuille Feuil2 (La forme finale peut être facilement adaptée au besoin, ici c'était pour faire sortir les combinaisons possibles)

Code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Option Explicit
 
Const Nb As Byte = 5                               'Nombre de manches
Dim n As Long
Dim R As Long
 
Sub TRAITEMENT()
Dim LastLig As Long, i As Long, j As Long
Dim TB() As Long, RES() As String
Dim k As Byte
Dim PART
 
With Feuil1
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    PART = .Range("A2:A" & LastLig)   'Plage des participants
    n = UBound(PART, 1)
    R = n / 4
 
    ReDim TB(1 To n, 1 To Nb)
    For k = 1 To Nb
        EQUIPES TB, k
    Next k
 
    ALEAT PART
 
    ReDim RES(1 To R, 1 To Nb)
    For k = 1 To Nb
        For i = 1 To n - 3 Step 4
            j = 1 + (i - 1) \ 4
            RES(j, k) = PART(TB(i, k), 1) & "-" & PART(TB(i + 1, k), 1) & "  <>  " & PART(TB(i + 2, k), 1) & "-" & PART(TB(i + 3, k), 1)
        Next i
    Next k
End With
 
Feuil2.Range("A2").Resize(R, Nb) = RES
MsgBox "Terminé  "
End Sub
 
'Permet d'organiser aléatoirement les éléments du tableau TBL
Private Sub ALEAT(ByRef TBL)
Dim i As Long, j As Long
 
For i = 1 To n
    Randomize
    j = CLng((n - i) * Rnd() + i)
    If i <> j Then INVERS TBL, i, j
Next i
End Sub
 
'Permet d'inverser les cellules i et j du tableau TBL
Private Sub INVERS(ByRef TBL, ByVal i As Long, ByVal j As Long)
Dim Tmp As String
 
Tmp = TBL(i, 1)
TBL(i, 1) = TBL(j, 1)
TBL(j, 1) = Tmp
End Sub
 
'Permet de classer les éléments du tableau TBL pour permettre de construire les équipes par partie (4 par 4)
Private Sub EQUIPES(ByRef TBL, ByVal k As Byte)
Dim i As Long, j As Long
 
For i = 1 To n
    If k = 1 Then
        TBL(i, 1) = i
    Else
        If j <= n - 4 And j <> 0 Then
            j = j + 4
        Else
            j = ((i - 1) \ R) + 1
        End If
        TBL(i, k) = TBL(j, k - 1)
    End If
Next i
End Sub

A ne pas oublier:
Pour avoir Nb manches, il faudra 4^Nb participants, sinon le résultat ne sera valable que pour les premières manches.

**rocornet** · 17/11/2013, 11h10

Peux tu me mettre ce code dans un classeur excel?
parce que j'ai essayé, mais ça me donne pas grand chose.
Merci d'avance

Les conditions sont:
Pierre avec luc contre jean et marcel
mais en 2ème partie il peut y avoir
Pierre jean contre jean marcel