VBA - tirage au sort aléatoire sans remise

Version imprimable

08/12/2015, 12h26
PaulineL

1 pièce(s) jointe(s)

VBA - tirage au sort aléatoire sans remise

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 :mouarf: !)
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 ! :D

bonne journée.

Ci joins le document : Pièce jointe 194715

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
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

10/12/2015, 08h39
PaulineL

Merci

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

Bonjour.

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
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

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

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
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

Bonjour.

Plus simple que mon précédent code :

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
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

Remplissage à partir de la ligne choisie

Bonjour à tous,

Je suis très novice sur VBA, je suis tombé sur ce sujet et en lisant j'ai trouvé un code qu'avait posté Docmarti ci-dessous.
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 Sub TriAleatoireConditionnel() nbrItem = 10 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 = 4 To nbrItem Cells(i, 3).Value = t(i) Next End Sub
J'ai utilisé le même code car cela répondait parfaitement à mon besoin. Malheureusement, quand je place le remplissage à la ligne 4, colonne 3, il me manque des chiffres au moment du remplissage.
Par exemple,

Code:

nbrItem = 10

et
Code:

1 2 3 For i = 4 To nbrItem Cells(i, 3).Value = t(i) Next
Je suis censé avoir un remplissage des chiffres de 1 à 10 ordonné aléatoirement. Malheureusement, il n'y a que 7 chiffres qui apparaissent. Savez-vous comment faire ?

Je vous remercie par avance de votre retour.

Bien à vous

Benam