Fête d'ami - VBA

Version imprimable

20/03/2012, 02h18
yanlau1977

Fête d'ami - VBA

Bonjour,

Je voudrais faire un petit programme excel très simple

Dans les cellules A1 à A30 ou A40 (environ) je veux inscrire tous les amis invités de mon fils.

Ensuite, je veux faire un tirage de 5 cadeaux. Les amis ne peuvent pas gagner plus d'une fois.

J'ai fait une fonction qui me permet de savoir le nombre d'enfants ... c'est déjà un bon début :)

Maintenant je voudrais bâtir une liste de tous les noms en mémoire et faire un random pour avoir 1 gagnant, enlever ce gagnant de la liste, refaire un random, enlever ce gagnant, etc ... le tout 5 fois.

Merci pour votre aide
20/03/2012, 04h31
kiki29

Salut, t'inspirer de http://excel.developpez.com/faq/?pag...rieNombresAlea

Merci pour l'aide l'ami ... je ne suis vraiment plus loin de solutionner le problème ...

Voici un exemple de feuille excel pour expliquer mon problème :
où A1 représente mon nombre de participant au tirage (5 dans cet exemple)
5 Cadeau 1 Cadeau 2 Cadeau 3 Cadeau 4 Cadeau 5
1
2
3
4
5

Voici l'appel
Code:

1 2 3 4 5 6 Sub Test() Dim NombreCadeau As Integer NombreCadeau = Range("A1").Value GenereSerieAleatoireSansDoublons NombreCadeau, Range("B2") End Sub
Voici la procedure
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 GenereSerieAleatoireSansDoublons(NbValeurs As Integer, Cell As Range) Dim Tableau() As Integer, TabNumLignes() As Integer Dim i As Integer, k As Integer, c As Integer ReDim Tableau(NbValeurs) ReDim TabNumLignes(NbValeurs) c = 2 For i = 1 To NbValeurs TabNumLignes(i) = i Tableau(i) = i Next 'Initialise le générateur de nombres aléatoires Randomize For i = NbValeurs To 1 Step -1 k = Int((i * Rnd) + 1) 'Cells(k + 1, c) = Tableau(TabNumLignes(k)) Cells(k + 1, c) = "BRAVO" c = c + 1 TabNumLignes(k) = TabNumLignes(i) Next End Sub
Résultats :
5	Cadeau 1	Cadeau 2	Cadeau 3	Cadeau 4	Cadeau 5
1	BRAVO			BRAVO	BRAVO
2		BRAVO	BRAVO		
3					
4					
5
Le # du gagnant est le BRAVO ... mais en réalité le BRAVO est le # du gagnant ... il ne va pas se mettre à la bonne ligne ... pourquoi ??

En inversant le commentaire, on comprend mieux mon explication ...
Code:

1 2 Cells(k + 1, c) = Tableau(TabNumLignes(k)) 'Cells(k + 1, c) = "BRAVO"
Désolé ... si quelqu'un comprend mes explications, c'est probablement un DIEU :)

Re, en fait dans la colonne A les participants et dans la colonne B on génère les nombres aléatoires
de 1 au nombre de participants , et ceux qui ont en vis à vis de leur nom les numéros 1 à 5
recevront les cadeaux correspondants

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
Option Explicit
 
Sub Test()
Dim LastRow As Long
    LastRow = ShTst.Range("A" & Rows.Count).End(xlUp).Row
    ShTst.Columns("B:B").ClearContents
    Application.ScreenUpdating = False
    GenereSerieAleatoireSansDoublons LastRow, ShTst.Range("B1")
    Application.ScreenUpdating = True
End Sub
 
Private Sub GenereSerieAleatoireSansDoublons(NbValeurs As Long, Cell As Range)
Dim Tableau() As Long, TabNumLignes() As Long
Dim i As Long, k As Long
 
    ReDim Tableau(NbValeurs)
    ReDim TabNumLignes(NbValeurs)
 
    For i = 1 To NbValeurs
        TabNumLignes(i) = i
        Tableau(i) = i
    Next i
 
    Randomize
 
    For i = NbValeurs To 1 Step -1
        k = Int((i * Rnd) + 1)
        ShTst.Cells(Cell.Row + i - 1, Cell.Column) = Tableau(TabNumLignes(k))
        TabNumLignes(k) = TabNumLignes(i)
    Next i
End Sub

ShTst est le CodeName attribué à Feuil1 ou Sheet1 chez toi, voir http://www.developpez.net/forums/d92...cel/vba-bases/

20/03/2012, 15h55
yanlau1977

Merci Kiki ... à lire ton code, je crois que tu as compris parfaitement mon besoin malgrè mes explications brouillées ...

J'ai hâte d'essayer le tout ce soir à la maison ... je te redonne des nouvelles.

Dommage, ca ne fonctionne pas tel que prévue ... surement que mes explications manques de clartés ... je recommence avec cet exemple

J'ai le tableau suivant :
6 Cadeau 1 Cadeau 2 Cadeau 3 Cadeau 4 Cadeau 5 Cadeau 6
1
2
3
4
5
6
7
8
9
10
11
12
13
la cellule A1 représente le nombre de cadeau offert, dans cet exemple "6"
Les lignes A2 et plus ... le nombre de participant au tirage.

Je veux générer un nombre aléatoire entre 1 et le nombre de participant pour chacun des cadeaux. Un participant ne peut pas gagner plus d'une fois ... la fonction GenereSerieAleatoireSansDoublons fonctionne parfaitement pour éviter d'avoir un gagnant en double ...

Là où ca accroche, c'Est que vis à vis chacun des participants, je veux inscrire "BRAVO" pour chacun des cadeaux ... c'est ca qui ne fonctionne pas ...

Voici mon code
Code:

1 2 3 4 5 6 7 Sub TestY() Dim NombreCadeau As Integer NombreCadeau = Range("A1").Value Feuil2.Range("B2", "G14").ClearContents GenereSerieAleatoireSansDoublons NombreCadeau, Range("B2") End Sub
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 GenereSerieAleatoireSansDoublons(NbValeurs As Integer, Cell As Range) Dim Tableau() As Integer, TabNumLignes() As Integer Dim i As Integer, k As Integer, col As Integer Dim LastRow As Integer ReDim Tableau(NbValeurs) ReDim TabNumLignes(NbValeurs) col = 2 LastRow = Feuil2.Range("A" & Rows.Count).End(xlUp).Row LastRow = LastRow - 1 'ENLEVER 1 valeur puisque A1 ne compte pas pour un participant ... pas très esthétique comme programmation désolé For i = 1 To NbValeurs TabNumLignes(i) = i Tableau(i) = i Next 'Initialise le générateur de nombres aléatoires Randomize For i = NbValeurs To 1 Step -1 k = Int((i * Rnd) + 1) Cells(k + 1, col) = Tableau(TabNumLignes(k)) 'Cells(k + 1, col) = "BRAVO" col = col + 1 TabNumLignes(k) = TabNumLignes(i) Next End Sub
Et voici le résultat
6 Cadeau 1 Cadeau 2 Cadeau 3 Cadeau 4 Cadeau 5 Cadeau 6
1 1 3 6
2 2
3
4 4
5 5
6
7
8
9
10
11
12
13
Dans cet exemple, ca fonctionné pour le cadeau 1,2,3 et 4. Le 5e cadeau, c'est le 3e participant qui aurait du gagné, mais ca écrit au participant 1, pareil pour le cadeau #6 ...

Merci

Re, en colonne C le Bravo
STP Balise ton 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
Option Explicit
 
Const NbCadeaux As Long = 5
 
Sub Test()
Dim LastRow As Long
    LastRow = ShTst.Range("A" & Rows.Count).End(xlUp).Row
    ShTst.Columns("B:C").ClearContents
    Application.ScreenUpdating = False
    GenereSerieAleatoireSansDoublons LastRow, ShTst.Range("B1")
    Application.ScreenUpdating = True
End Sub
 
Private Sub GenereSerieAleatoireSansDoublons(NbValeurs As Long, Cell As Range)
Dim Tableau() As Long, TabNumLignes() As Long
Dim i As Long, k As Long
 
    ReDim Tableau(NbValeurs)
    ReDim TabNumLignes(NbValeurs)
 
    For i = 1 To NbValeurs
        TabNumLignes(i) = i
        Tableau(i) = i
    Next i
 
    Randomize
 
    For i = NbValeurs To 1 Step -1
        k = Int((i * Rnd) + 1)
        ShTst.Cells(Cell.Row + i - 1, Cell.Column) = Tableau(TabNumLignes(k))
        TabNumLignes(k) = TabNumLignes(i)
    Next i
 
    For i = 1 To NbValeurs
        If ShTst.Range("B" & i) <= NbCadeaux Then
            ShTst.Range("C" & i) = "Bravo"
        End If
    Next i
End Sub

21/03/2012, 05h21
yanlau1977

Mon petit programme est plus compliqué que je l'avais imaginé ...

Kiki, ton code ne fait pas ce que j'aimerais qu'il fasse ... et je n'arrive pas à trouver ma solution, ca devient vraiment complexe à programmer ...

Le tirage au sort soit se faire en x étapes, autant d'étape qu'il y a de cadeaux.

Le premier résultat doit écrire BRAVO vis à vis la ligne du participant ayant remporté le prix et vis à vis la colonne "Cadeau 1".

Le deuxième résultat doit écrire BRAVO vis à vis la ligne du participant ayant remporté le prix et vis à vis la colonne "Cadeau 2".

Le troisième résultat ........ vis à vis la colonne "Cadeau 3"

Le quatrième résultat ......... vis à vis la colonne "Cadeau 4"

etc ... jusqu'au 6e cadeau.

Bon courage au pro du VBA ... moi j'ai la tête qui devient folle :aie:
21/03/2012, 06h21
kiki29

Re, ma solution est simple et cohérente, ton approche est du genre pourquoi faire simple quant on peut faire compliqué, après ce n'est que de l'habillage et là c'est à toi de poursuivre
21/03/2012, 23h53
yanlau1977

C'est dommage, mon message de 00h44 était tellement prêt de la vérité ...

Il manque un petit truc qui sort de mes connaissances ... Il doit bien avoir un génie dans ce Forum qui trouverait le petit bug !!!

à suivre ...

Re, au plus simple en reportant le tirage sur une autre feuille avec un CodeName ShCad, mais en une seule étape et pas en 6

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
Option Explicit
 
Const NbCadeaux As Long = 6
 
Sub Test()
Dim LastRow As Long
    LastRow = ShTst.Range("A" & Rows.Count).End(xlUp).Row
    ShTst.Columns("B:C").ClearContents
    Application.ScreenUpdating = False
    GenereSerieAleatoireSansDoublons LastRow, ShTst.Range("B1")
    Application.ScreenUpdating = True
End Sub
 
Private Sub GenereSerieAleatoireSansDoublons(NbValeurs As Long, Cell As Range)
Dim Tableau() As Long, TabNumLignes() As Long
Dim i As Long, k As Long
 
    ReDim Tableau(NbValeurs)
    ReDim TabNumLignes(NbValeurs)
 
    For i = 1 To NbValeurs
        TabNumLignes(i) = i
        Tableau(i) = i
    Next i
 
    Randomize
 
    For i = NbValeurs To 1 Step -1
        k = Int((i * Rnd) + 1)
        ShTst.Cells(Cell.Row + i - 1, Cell.Column) = Tableau(TabNumLignes(k))
        TabNumLignes(k) = TabNumLignes(i)
    Next i
 
    ShCad.Cells.Clear
    For i = 1 To NbValeurs
        If ShTst.Range("B" & i) <= NbCadeaux Then
            ShTst.Range("C" & i) = "Bravo"
 
            ShCad.Cells(1, ShTst.Range("B" & i)) = "Cadeau " & ShTst.Range("B" & i)
            ShCad.Cells(2, ShTst.Range("B" & i)) = ShTst.Range("A" & i)
        End If
    Next i
End Sub

22/03/2012, 05h04
yanlau1977

Merci Kiki, ton dernier exemple ma permis de trouver la réponse à mon problème ... j'apprécie.

Désolé pour les gestionnaires du Forum, mais je ne sais pas comment vous faite pour écrire en code dans un post ... si quelqu'un peut me donner un tips, je me corrigerais pour mes prochains post.

J'ai mon tableau de créé

Code:

ReDim Tableau(NombreEnfant) 'il y a 25 enfants

Je fais un tirage de cadeau "RANDOM" sur 1 des 25 enfants

Code:

k = Int((NombreEnfant * Rnd) + 1)

Le gagnant est l'enfant #12 admettons ...

Comment je fais pour enlever l'enfant #12 de mon tableau ?

J'ai essayé plusieurs trucs et je ne trouve pas ...
22/03/2012, 06h54
casefayere

Bonjourà tou(te)s, yanlau1977

Citation:

Désolé pour les gestionnaires du Forum, mais je ne sais pas comment vous faite pour écrire en code dans un post ... si quelqu'un peut me donner un tips, je me corrigerais pour mes prochains post.

Juste au dessus de ton message, tu as "#", cliques dessus et écris ton code à l'intérieur ou écris ton code, selectionnes le et cliques sur "#"

Bonne journée
22/03/2012, 13h15
yanlau1977

TEST - TEST

Code:

ReDim Tableau(NombreEnfant) 'il y a 25 enfants

Code:

k = Int((NombreEnfant * Rnd) + 1)

EDIT

Bonjour
Ci-joint une proposition (avec la disposition des données comme ceci)

Feuille: Feuille nommée Feuil1
En colonne A à partir de A2 la liste des amis
En Ligne 1 à partir de B1, la liste des cadeaux

La procédure DispatchCadeaux permet d'inscrire BRAVO dans la cellule d'intersection du cadeau avec la personne tirée aléatoirement.

Code utilisant les variables tableaux

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
Sub DispatchCadeaux()
Dim m As Integer, n As Integer, i As Integer, j As Integer
Dim Res() As String
Dim Tb() As Integer
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    n = .Range("A1").End(xlDown).Row - 1
    m = .Range("A1").End(xlToRight).Column - 1
 
    ReDim Tb(1 To n)
    For i = 1 To n
        Tb(i) = i
    Next i
 
    ReDim Res(1 To n, 1 To m)
 
    For j = 1 To m
        Call AleaPermut(Res, Tb, j)
    Next j
 
    .Range("B2").Resize(n, m) = Res
End With
End Sub
 
 
Private Sub AleaPermut(ByRef Mtr, ByRef Vct, ByVal k As Integer)
Dim p As Integer, i As Integer, q As Integer
 
q = UBound(Mtr, 1) - k + 1
 
Randomize
p = Int(q * Rnd) + 1
Mtr(Vct(p), k) = "BRAVO"
 
For i = 1 To q - 1
    Vct(i) = IIf(i < p, Vct(i), Vct(i + 1))
Next i
End Sub