XL 2016 Tirage pour une tombola

[Reija05]

Bonjour,
je voudrais faire une macro pour un tirage de tombola
Dans la colonne A on met les numéros des tickets vendus
En cliquant sur le bouton "Tirage au sort Tombola" la colonne D s'incrémente au nombre de lot renseigné dans la message box et la colonne E les numéros tirés au sort au hasard à partir de la colonne A.

Mon souci c'est que les numéros tirés sont parfois présent en double.
Je ne sais pas comment faire pour que ce tirage aléatoire évite les doublons?
Pourriez vous m'aider?
Merci

 

[halecs93]

Bonjour,
je voudrais faire une macro pour un tirage de tombola
Dans la colonne A on met les numéros des tickets vendus
En cliquant sur le bouton "Tirage au sort Tombola" la colonne D s'incrémente au nombre de lot renseigné dans la message box et la colonne E les numéros tirés au sort au hasard à partir de la colonne A.

Mon souci c'est que les numéros tirés sont parfois présent en double.
Je ne sais pas comment faire pour que ce tirage aléatoire évite les doublons?
Pourriez vous m'aider?
Merci

Avec le code modifié comme suit

Sub Bouton1_Cliquer()

    Dim LastLig As Integer, i As Integer, j As Integer
    Dim k As Integer, m As Integer, Lot As Integer
    Dim Deb As Integer, x As Long, LotNum As Integer, LotLig As Integer
    Dim incr As Integer, NbLot As Integer
    Dim CompareVal As Variant
    Dim Tb As Variant

    Application.ScreenUpdating = False

    With Sheets("ListTicket")    'à adapter

        LastLig = .Cells(Rows.Count, 1).End(xlUp).Row

        ' partie qui génère la liste de lots
        Dim InputNbLot As Variant
        InputNbLot = InputBox("Combien de lots cette année?", "Nombre Total de Lots")

        ' vérifier si l'entrée est un nombre valide
        If IsNumeric(InputNbLot) And InputNbLot <> "" Then  ' Si nombre de lot pas rempli ou non numérique alors message d'erreur
            Lot = CInt(InputNbLot)  ' Transforme le chiffre de la boîte de dialogue en valeur numérique

            ' Vérification que le nombre de lots n'excède pas le nombre de valeurs disponibles dans la colonne A
            If Lot > LastLig - 1 Then
                MsgBox "Le nombre de lots demandé dépasse le nombre de numéros disponibles."
                Application.ScreenUpdating = True
                Exit Sub
            End If

            LotLig = Lot + 2  ' On ajoute 2 car le remplissage de la colonne commence à 3 donc le dernier lot sera à x+2
            Deb = 3  ' On commence à la ligne 3
            LotNum = 1  ' le premier lot commence à 1
            incr = 1  ' on incrémente de 1 en 1

            ' Génération des lots
            For x = Deb To Lot + Deb - 1
                Sheets("ListTicket").Cells(x, 4).Value = LotNum
                LotNum = LotNum + incr
            Next x

            ' partie qui génère le tirage au sort
            i = 3: j = 5  ' coordonnées de la 1ère cellule où écrire les données
            Tb = .Range("A2:A" & LastLig).Value  ' Liste des valeurs dont on veut un tirage
            CompareVal = Range("E3:E" & LastLig)  ' Création de la sélection colonne E

            Do While Lot > 0
                Randomize
                m = Int((LastLig - 1) * Rnd() + 1)  ' sélection aléatoire de valeur
                .Cells(i, j).Value = Tb(m, 1)  ' mettre la valeur dans la cellule

                ' Déplacement des valeurs restantes pour éviter les doublons
                For k = m To UBound(Tb) - 1
                    Tb(k, 1) = Tb(k + 1, 1)
                Next k

                LastLig = LastLig - 1
                Lot = Lot - 1
                i = i + 1
            Loop
        Else
            MsgBox "Donner un nombre valide pour le nombre total de lots"
        End If
    End With

    Application.ScreenUpdating = True

End Sub

 

[dysorthographie]

Bonjour,
En initialisant une collection avec la liste des tickets vendu puis en retirant de la collection les tickets attribués aléatoirement.

Sub Jeux()
Dim Nb As Integer, i As Integer, T As Integer, Tickets As New Collection
Nb = Application.InputBox("Veuillez entrer un nombre entier :", "Saisie d'un nombre entier", Type:=1)
If nb=0 then exit sub
With ThisWorkbook.Sheets("ListTicket")
    .Range(.Range("D3"), .Cells(.Rows.Count, "D").End(xlUp).Offset(3, 1)).Clear
' initialisation de la collection de tickets
    For i = 2 To .Range("A1").CurrentRegion.Rows.Count
        Tickets.Add CStr(.Cells(i, "A"))
    Next
      Randomize Timer
    For i = 1 To Nb
        .Range("D2").Offset(i) = i
         ' Tirage allétoire
        T = Int(Tickets.Count * Rnd() + 1)
        .Range("E2").Offset(i) = Tickets(T)
        Tickets.Remove (T) ' suppression du ticket.
    Next
End With
Set Tickets = Nothing
End Sub

 

[Dranreb]

Bonsoir.
Ma solution.
Mais je suis allé à la facilité pour moi. Je peux vous l'écrire sans utiliser d'objet ListeAléat si vous préférez.

Option Explicit
Sub Bouton1_Cliquer()
   Dim TTck(), LAt As New ListeAléat, LTir As Long, LTck As Long, TTir()
   TTck = Feuil1.[A2].Resize([A1000000].End(xlUp).Row - 1).Value
   Randomize
   LAt.Init UBound(TTck, 1)
   LTir = InputBox("Combien de lots cette année ?", "Nombre Total de Lots")
   If LTir > UBound(TTck, 1) Then LTir = UBound(TTck, 1)
   ReDim TTir(1 To LTir, 1 To 2)
   For LTir = 1 To UBound(TTir, 1)
        LTck = LAt.Aléat(LTir)
        TTir(LTir, 1) = LTir
        TTir(LTir, 2) = TTck(LTck, 1)
        Next LTir
   Feuil1.[D3:E5000].ClearContents
   Feuil1.[D3].Resize(UBound(TTir, 1), 2).Value = TTir
   End Sub

 

[mapomme]

Bienvenue @Reija05 sur XLD
Bonsoir aux autres ,

La petite macro de ma pomme. Sans boucle, sans collection, sans dictionary...
On procède à quelques vérifications :

• validité du nombre de lots
• comparaison du nombre de tickets avec le nombre de lots
• possibilité d'un tirage déjà existant (dans ce cas demande de confirmation)
• on supprime les tickets en double

Le code est commentée (un peu) :

Sub tirageAlea()
Dim nbrLot&, derlig&, nbrTicket&, rep
   Application.ScreenUpdating = False                                ' pas d'actualisation de l'affichage (plus rapide)
   rep = Application.CountA(Range("d3:e3").Resize(Rows.Count - 2))   ' nombre de valeurs dans le tirage déjà affiché
   If rep > 0 Then   ' si un tirage semble exister
      rep = MsgBox("Il est possible qu'un tirage existe déjà." & vbLf & _
         "Voulez-vous le supprimer et procéder à un nouveau tirage ?", vbQuestion + vbYesNo + vbDefaultButton2)   ' on demande de confirmer le tirage
      If rep <> vbYes Then MsgBox "Abondon du tirage", vbInformation: Exit Sub      ' si refus d'un nouveau tirage, on arrête la macro
   End If
   Sheets("ListTicket").Select                  ' sélection de la feuille "ListTicket"
   Range("d3:e" & Rows.Count).ClearContents     ' effacement du précédent tirage
   nbrLot = CLng(Val(InputBox("Nombre de lot pour cette année ?" & vbLf & "( >0 ou sinon on quitte l'exécution) :")))   ' demande du nombre de lots
   If nbrLot <= 0 Then MsgBox "Aucun lot ! Arrêt de l'exécution.", vbCritical: Exit Sub   ' si le nombre de lot n'est pas supérieur à 0 alors on arrête la macro
   Range("a1").Resize(Rows.Count).RemoveDuplicates , Header:=xlYes   ' par précaution, on supprime les tickets en doublons
   nbrTicket = Cells(Rows.Count, "a").End(xlUp).Row - 1     ' le nombre de tickets
   If derlig = 1 Then MsgBox "Aucun ticket => on quitte l'exécution", vbCritical: Exit Sub   ' si aucun ticket alors on arrête la macro
   If nbrLot > nbrTicket Then nbrLot = nbrTicket      ' on ramène le nombre de lots au nombre de tickets (si plus de lots que de tickets)
   Range("a2").Resize(nbrTicket).Copy Range("e3")     ' on recopie la liste des tickets en colonne E
   Range("d3").Resize(nbrTicket).Formula = "=RAND()"  ' on met des nombres aléatoires dans la colonne D via une formule
   Range("d3:e3").Resize(nbrTicket).Sort key1:=Range("d3"), Header:=xlNo   ' on trie les colonnes D à E en fonction de la colonne E
   Range("d3").Resize(nbrLot).Formula = "=ROW()-2"                         ' dans la colonne D, on met une formule pour mettre les valeurs 1, 2, 3, ...
   Range("d3").Resize(nbrLot) = Range("d3").Resize(nbrLot).Value           ' on convertit les formules en leur valeur
   Range(Cells(nbrLot + 3, "d"), Cells(Rows.Count, "e")).ClearContents     ' on efface les lignes sous le dernier lot
End Sub

 

[Dranreb]

J'ai retrouvé un système de tombola qui m'avait été demandé.
Les carnets de tickets peuvent être de couleurs différentes et reprendre alors les mêmes séries de numéros.
Il y a aussi une gestion du budget.
… Et un dévoilement progressif des numéros gagnants.

 

[jurassic pork]

Hello,
une autre possibilité est d'utiliser la classe VBA BetterArray (licence MIT) qui permet des traitements sur les tableaux (tri , slice, mélange). On va ici utiliser la fonction Shuffle (mélange) pour mélanger de façon aléatoire le tableau des numéros de tombola et après on peut aller prendre dedans le nombre de numéros désirés :

Sub Bouton1_Cliquer()
    Dim LTir As Long, i As Long
    Dim MyArray As BetterArray
    Set MyArray = New BetterArray
    Application.ScreenUpdating = False
    Feuil1.[D3:E5000].ClearContents
    MyArray.FromExcelRange Feuil1.[A2].Resize([A1000000].End(xlUp).row - 1)
    MyArray.Shuffle  ' mélange  des éléments du tableau
    LTir = InputBox("Combien de lots cette année ?", "Nombre Total de Lots")
    For i = 1 To LTir
       Feuil1.[D3].offset(i - 1, 0) = i
       Feuil1.[E3].offset(i - 1, 0) = MyArray.Items(i)
    Next i
    Application.ScreenUpdating = True
End Sub

Pour que cela fonctionne il faut importer le fichier de classe BetterArray.cls dans son projet

[EDIT] version sans boucle :

Sub Bouton1_Cliquer()
    Dim LTir As Long, i As Long
    Dim MyArray As BetterArray
    Set MyArray = New BetterArray
    Feuil1.[D3:E5000].ClearContents
    MyArray.FromExcelRange Feuil1.[A2], True ' Last Row
    MyArray.Shuffle  ' mélange  des éléments du tableau
    LTir = InputBox("Combien de lots cette année ?", "Nombre Total de Lots")
    Feuil1.[D3] = 1: Feuil1.[D3].Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=LTir
    MyArray.Capacity = LTir
    MyArray.ToExcelRange Feuil1.[E3]
End Sub

Ami calmant, J.P

 

[Reija05]

Merci pour toutes vos réponses je vais regarder ça de plus prêt, et comprendre tout ça.
Je reviendrai si des zones obscures subsistent.
Merci pour tout