Tirage au sort

Version imprimable

12/12/2010, 22h38
Sylcoco

Tirage au sort

Bonjour,

J'aimerai réaliser un tirage au sort pour des matchs de badminton en double. Le départ étant une liste de x noms (40 pour l'exemple). Le résultat attendu: une équipe de deux face à une autre équipe de deux. Ce tirage étant réalisable plusieurs fois sans doublons dans la mesure du possible.

D'avance merci de l'aide qui pourrait m'être apportée.

Sylvain
13/12/2010, 18h04
alainb
Bonsoir Sylvain,
Cette macro Visual Basic crée un nombre entier aléatoire compris entre 0 et 40:
Code:

1 2 3 4 5 6 7 8 9 Sub nombreAleatoireDansPlageValeurs() Dim Mini As Integer, Maxi As Integer Mini = 0 Maxi = 40 Randomize MsgBox Int((Maxi - Mini + 1) * Rnd + Mini) End Sub
L'instruction Randomize, utilisée sans argument, permet au générateur de nombres aléatoires de démarrer à chaque fois sur une valeur différente.
En l'absence de Randomize, la fonction Rnd adopte le même nombre comme valeur initiale la première fois qu'elle est appelée.

Ce code est sur la FAQ Excel
Alain
13/12/2010, 19h55
Sylcoco

Alain,

Merci pour cette macro. J'avoue ne pas maitriser du tout le VBA, je m'y intéresse depuis peu seulement.
J'apporte quelques précisions quant au résultat que je souhaiterai obtenir:

-colonne A, une suite de noms. De C1 à F1 je souhaiterai que la "macro qui va bien" sorte 4 noms de façon aléatoire provenant de la liste en A, et ainsi de suite de C2 à F2, etc... et que je puisse renouveler l'opération.

Est-ce possible ?

Sylvain

une possibilité

Code:

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
Sub TirageAlea()
Dim LastLig As Integer, i As Integer, j As Integer, k As Integer, m As Integer
Dim Tb As Variant
 
Application.ScreenUpdating = False
With Sheets("Feuil1")    'à adpter
     LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
     i = 1: j = 3
     Tb = .Range("A1:A" & LastLig).Value
     Do
          Randomize
          m = Int(LastLig * Rnd() + 1)
          .Cells(i, j).Value = Tb(m, 1)
          For k = m + 1 To LastLig
               Tb(k - 1, 1) = Tb(k, 1)
          Next k
          If j = 6 Then
               j = 3
               i = i + 1
          Else
               j = j + 1
          End If
          LastLig = LastLig - 1
     Loop While LastLig > 0
End With
End Sub

14/12/2010, 01h26
fring

1 pièce(s) jointe(s)

Bonjour,

Il y a quelques temps je m'étais fais un tableau pour un tournoi de backgammon, tournoi de type "Suisse", c'est à dire que chaque équipe rencontre une et une seule fois toutes les autres équipes. Le nombre d'équipes peut être pair ou impair.
Pour l'attribution du numéro de chaque équipe j'avais procédé par un bon vieux tirage de petits papiers dans un chapeau :mrgreen:

Je te joins le fichier, ça pourra peut-être te servir
14/12/2010, 22h29
Sylcoco

Merci fring, pour cette participation. Je vais tenter d'étudier les macros de ton fichier.

sylvain

Bonsoir Mercatoq,

La macro que tu proposes donne le résulat que j'attendais. J'ose approfondir ma demande. Serait-il possible de pouvoir faire des tirages uniquement avec les noms masculin, ou féminin, voire les deux mélangés pour faire des doubles mixtes. Je me dis que si dans une feuille je ne met que les noms masculins j'aurai un tirage n'engageant que les hommes et idem si je met les noms féminins dans une autre. Mais pour un tirage d'équipe mixte ? Est-ce qu'un codage par 1 ou 2 mis en face de chaque nom masculin ou féminin aiderait pour ces différents tirages à réaliser.

Sylvain

Tirage mixte, colonne A noms, colonne B le sexe "M" ou "F"

Code:

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
Sub TirageAleaMixte()
Dim LastLigm As Integer, i As Integer, j As Integer, k As Integer, m As Integer
Dim Tbm As Variant, Sx As String
Dim t As Long
 
Application.ScreenUpdating = False
With Sheets("Feuil1")    'à adpter
     LastLigm = .Cells(Rows.Count, 1).End(xlUp).Row
     Tbm = .Range("A1:B" & LastLigm).Value
     i = 1: j = 3: Sx = "F"
     Do
          t = t + 1
          Randomize
          m = Int(LastLigm * Rnd() + 1)
          If Tbm(m, 2) = Sx Then
               Sx = IIf(Sx = "F", "M", "F")
               .Cells(i, j).Value = Tbm(m, 1)
               For k = m + 1 To LastLigm
                    Tbm(k - 1, 1) = Tbm(k, 1)
                    Tbm(k - 1, 2) = Tbm(k, 2)
               Next k
               LastLigm = LastLigm - 1
               If j = 6 Then
                    j = 3
                    i = i + 1
               Else
                    j = j + 1
               End If
          End If
     Loop While LastLigm > 0 And t < LastLigm * LastLigm
End With
End Sub

15/12/2010, 11h12
Sylcoco

Mercatoq,

Je ne sais pas si c'est moi qui ai mal recopié cette nouvelle macro mais rien ne se passe. J'ai remarqué également que la précédente laisse des cellules vides bien que la colonne A comporte un nombre paire de noms. Avec 40 noms, le tirage devrait compléter 4 cellules à l'horizontale sur 10 lignes. Peut-on éviter ces cellules vides ?
Sinon grand merci pour le travail accompli.

Sylvain
15/12/2010, 14h51
rjamin

Confirmation

Bonjour,

Je confirme le bon fonctionnement des deux procédures, quel que soit le nombre de noms en colonne A

Code:

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
Dim Tb As Variant, Tbm() As String
Dim LastLig As Integer, i As Integer, j As Integer, k As Integer, m As Integer
Dim Nb As Integer, t As Integer, s As Integer
 
Application.ScreenUpdating = False
With Sheets("Feuil1")    'à adpter
     LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
     Nb = Application.CountIf(.Range("B1:B" & LastLig), "M")
     If Nb * (LastLig - Nb) > 0 Then
          Nb = Application.Min(Nb, LastLig - Nb)
          Tb = .Range("A1:B" & LastLig).Value
          ReDim Tbm(1 To 2, 1 To Nb)
          Do
               Randomize
               m = Int(LastLig * Rnd() + 1)
               If Tb(m, 2) = "M" And t < Nb Then
                    t = t + 1
                    Tbm(1, t) = Tb(m, 1)
               ElseIf Tb(m, 2) = "F" And s < Nb Then
                    s = s + 1
                    Tbm(2, s) = Tb(m, 1)
               End If
               For k = m + 1 To LastLig
                    Tb(k - 1, 1) = Tb(k, 1)
                    Tb(k - 1, 2) = Tb(k, 2)
               Next k
               LastLig = LastLig - 1
          Loop Until s = Nb And t = Nb
 
          i = 1: j = 3: s = 1: t = 1
          For k = 1 To 2 * Nb
               If k Mod 2 = 0 Then
                    .Cells(i, j).Value = Tbm(1, t)
                    t = t + 1
               Else
                    .Cells(i, j).Value = Tbm(2, s)
                    s = s + 1
               End If
               i = IIf(j = 6, 1, 0) + i
               j = IIf(j = 6, 3, j + 1)
          Next k
     End If
End With