Discussion :

[PaulineL]

Bonjour,

je suis débutante en VBA et j'aurais besoin de votre aide s'il vous plait.
Je souhaite mettre en place un tirage au sort aléatoire sans remise et que la personne qui tire ne puisse pas se tirer elle même (logique !)
J'ai déjà commencé la formule en VBA, j'ai réussi à faire le tirage aléatoire. Mais j'ai un soucis sur le fait de ne pas repiocher la même personne et le fait que la personne ne puisse pas se piocher elle même.

merci d'avance pour votre aide !

bonne journée.


Ci joins le document : tirage_au_sort.xlsm

[Invité]

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
Sub tirage_au_sort()
Dim indice_ligne_secret_santa, indice_courant As Integer
 
indice_ligne_secret_santa = 2
indice_courant = 2
Dim Dico As Object
 Set Dico = CreateObject("Scripting.Dictionary")
While indice_ligne_secret_santa < 7
    Randomize
    nombre_aleatoire = 0
    Do While nombre_aleatoire = 0
    nombre_aleatoire = Int(6 * Rnd) + 2
 
    salarie_choisi = nombre_aleatoire
    If Dico.exists(Cells(salarie_choisi, "A").Value) = False Then Dico.Add Cells(salarie_choisi, "A").Value, Cells(salarie_choisi, "A").Value Else nombre_aleatoire = 0
    Loop
    If Cells(salarie_choisi, 3) > 0 And Cells(salarie_choisi, 1) <> indice_ligne_secret_santa Then
 
        MsgBox "Le salarie " & indice_ligne_secret_santa & " a choisi  " & salarie_choisi
 
        Cells(salarie_choisi, 3) = indice_ligne_secret_santa
    If Cells(salarie_choisi, 1) <> indice_ligne_secret_santa Then
    Randomize
    End If
    End If
       indice_ligne_secret_santa = indice_ligne_secret_santa + 1
Wend
 
 
End Sub

[PaulineL]

Je remercie pour votre aide
Cependant je ne comprends pas pourquoi à chaque fois la formule ne s'applique pas à 1 ou 2 personnes :/ ?

[Docmarti]

Bonjour.

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
Sub Cadeaux()
Randomize Timer
recommencetout:
  nbr = 0
  For i = 2 To 7
   nbr = nbr + 1
   Cells(i, 1) = nbr
   Cells(i, 3) = nbr
  Next
 
 For i = 2 To 7
 
 ok = 0
encoreunefois:
 
  moi = Cells(i, 1)
 
  toi = moi
  While moi = toi
   toi = Int(6 * Rnd) + 1
  Wend
 
  If Cells(toi + 1, 3) = moi Or Cells(moi + 1, 3) = toi Then
       ok = ok + 1
    If ok < 1000 Then
     GoTo encoreunefois
    Else
     MsgBox "Il y a un probleme"
     GoTo recommencetout
    End If
 
   End If
   tmp = Cells(moi + 1, 3)
   Cells(moi + 1, 3) = Cells(toi + 1, 3)
   Cells(toi + 1, 3) = tmp
 Next
 
End Sub

[Invité]

Bonjour,
ça vient de là indice_ligne_secret_santa = indice_ligne_secret_santa + 1

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
Sub tirage_au_sort()
Dim indice_ligne_secret_santa, indice_courant As Integer
 
indice_ligne_secret_santa = 2
indice_courant = 2
Dim Dico As Object
 Set Dico = CreateObject("Scripting.Dictionary")
While indice_ligne_secret_santa < 7
    Randomize
    nombre_aleatoire = 0
    Do While nombre_aleatoire = 0
    nombre_aleatoire = Int(6 * Rnd) + 2
 
    salarie_choisi = nombre_aleatoire
    If Dico.exists(Cells(salarie_choisi, "A").Value) = False Then Dico.Add Cells(salarie_choisi, "A").Value, Cells(salarie_choisi, "A").Value Else nombre_aleatoire = 0:indice_ligne_secret_santa =indice_ligne_secret_santa -1
    Loop
    If Cells(salarie_choisi, 3) > 0 And Cells(salarie_choisi, 1) <> indice_ligne_secret_santa Then
 
        MsgBox "Le salarie " & indice_ligne_secret_santa & " a choisi  " & salarie_choisi
 
        Cells(salarie_choisi, 3) = indice_ligne_secret_santa
    If Cells(salarie_choisi, 1) <> indice_ligne_secret_santa Then
    Randomize
    End If
    End If
       indice_ligne_secret_santa = indice_ligne_secret_santa + 1
Wend
 
 
End Sub

[Docmarti]

Bonjour.

Plus simple que mon précédent 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
Sub TriAleatoireConditionnel()
 
nbrItem = 6
 
ReDim t(1 To nbrItem)
 
For i = 1 To nbrItem
 t(i) = i
Next
 
Randomize Timer
 
For i = 1 To nbrItem
    A = i 'sujet A
 'inverser le choix du sujet A avec le choix d'un autre sujet choisi aleatoirement
 ok = False
 While ok = False
 
  'choisir sujet B different de sujet A
   B = A
  While B = A
   B = Int(nbrItem * Rnd) + 1
  Wend
 
  'Inversion conditionnelle
  'inverser leurs choix a la condition de ne pas se choisir soi-meme
  If t(B) <> A And t(A) <> B Then
   tmp = t(A):  t(A) = t(B):  t(B) = tmp
   ok = True
  End If
 
 Wend
 
Next
 
For i = 1 To nbrItem
 Cells(i, 3).Value = t(i)
Next
 
End Sub