Modification macro de tirage

bonjour

je souhaiterai modifier la macro suivante, elle fonction mais le tirage commence à ligne 1 et je voudrais qu'elle démarre à la ligne 10

merci d'avance pour votre aide

philippe

Sub Tirage6NumérosAvecFavoris()

Dim Cellules As Range
Dim x1 As Integer
Dim x2 As Integer
Dim lg As Integer
Dim z As Integer
Dim i As Integer
Dim nb As Integer
Dim num As Integer
Dim lenum As Double
Dim j As Integer
Dim plg As Range
Dim maxi As Integer

Sheets("tirage").Activate
Application.ScreenUpdating = False
Sheets("tirage").Range("A:A").ClearContents
Set Cellules = Sheets("classement_ind").Range("B4:B303") 'maxi 300 équipes
x1 = 1 'nbre mini
x2 = Sheets("tirage").Range("E2").Value 'nbre d'équipes sur le tournoi
lg = 1 '1° ligne tirage

nb = [E1] 'Nbre constaté de favoris (plage nommée "Favoris"), mise à jour manuelle f(x) des parties
    If nb > x2 Then
    MsgBox ("Y'a un problème en quelque part Favoris>nb d'équipes?")
    Else

    For i = 1 To nb 'tirage favoris
        z = 1 '1° colonne tirage
        num = Application.Index([Favoris], [int(rand()*(E1)+1)]) 'tirage aléatoire entre bornes
        If Application.CountIf([Tirage], num) = 1 Then             'vérif doublons et nbre max de favoris
            i = i - 1
        Else: Cells(lg, z) = num: lg = lg + 1
        End If
    Next i
    lg = nb + 1
    z = 1
    End If

For j = nb + 1 To Range("E2").Value 'tirage autres numéros

      maxi = Range("E2").Value
      Set plg = Range(Cells(1, 1).Address & ":" & Cells(maxi, 1).Address)
      lenum = Evaluate("int(rand()*(" & x2 + 1 & "-" & x1 & ")+" & x1 & ")")
      If Application.WorksheetFunction.CountIf(plg, lenum) = 1 Or IsNumeric(Application.Match(lenum, [Favoris], 0)) Then
        j = j - 1
        z = 1 '1° colonne tirage
      Else: Cells(lg, z) = lenum: lg = lg + 1
      End If
Next j

'tri croissant
'plg.Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlLeftToRight
lg = lg + 1:    z = z + 1
Application.ScreenUpdating = True
End Sub

Bonsoir,

pas essayé mais essayez de remplacer lg=1 par lg=10

@ bientôt

LouReeD

bonjour LouReeD,

j'ai bien essayé ça déjà mais je pense que la partie du code pour les favori fait Buguer le résultat.

Pour faire simple je souhaite dans la feuille tirage indiquer un nb d'inscrits en E3. le tirage doit s'affiche de A10:A610 (600 inscrits maxi)

La macro doit effacer le tirage précédent da A10 :a610 et effectuer un tirage aléatoire sans doublon en fonction du nb d’inscrits en E3.

merci pour ton aide

Bonsoir,

désolé j'ai survolé le code un peu vite !

Surligné, ce qu'il faut changer :

Sub Tirage6NumérosAvecFavoris()

Dim Cellules As Range
Dim x1 As Integer
Dim x2 As Integer
Dim lg As Integer
Dim z As Integer
Dim i As Integer
Dim nb As Integer
Dim num As Integer
Dim lenum As Double
Dim j As Integer
Dim plg As Range
Dim maxi As Integer

Sheets("tirage").Activate
Application.ScreenUpdating = True
Sheets("tirage").Range("A:A").ClearContents
Set Cellules = Sheets("classement_ind").Range("B4:B303") 'maxi 300 équipes
x1 = 1 'nbre mini
x2 = Sheets("tirage").Range("E2").Value 'nbre d'équipes sur le tournoi
lg = 10 '1° ligne tirage en fait ça sert à rien car lg est défini autrement plus bas dans le code

nb = [E1] 'Nbre constaté de favoris (plage nommée "Favoris"), mise à jour manuelle f(x) des parties
    If nb > x2 Then
    MsgBox ("Y'a un problème en quelque part Favoris>nb d'équipes?")
    Else

    For i = 1 To nb 'tirage favoris
        z = 1 '1° colonne tirage
        num = Application.Index([Favoris], [int(rand()*(E1)+1)]) 'tirage aléatoire entre bornes
        If Application.CountIf([Tirage], num) = 1 Then             'vérif doublons et nbre max de favoris
            i = i - 1
        Else: Cells(lg, z) = num: lg = lg + 1
        End If
    Next i
   lg = nb + 10 ' ici lg est "redéfinit" du coup la première modification est inhibée et il faut le redéfinir comme 10...    z = 1
    End If

For j = nb + 1 To Range("E2").Value 'tirage autres numéros

      maxi = Range("E2").Value
      Set plg = Range(Cells(1, 1).Address & ":" & Cells(maxi, 1).Address)
      lenum = Evaluate("int(rand()*(" & x2 + 1 & "-" & x1 & ")+" & x1 & ")")
      If Application.WorksheetFunction.CountIf(plg, lenum) = 1 Or IsNumeric(Application.Match(lenum, [Favoris], 0)) Then
        j = j - 1
        z = 1 '1° colonne tirage
      Else: Cells(lg, z) = lenum: lg = lg + 1
      End If
Next j

'tri croissant
'plg.Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlLeftToRight
lg = lg + 1:    z = z + 1
Application.ScreenUpdating = True
End Sub

Voilà, maintenant je pense que ça marche

@ bientôt

LouReeD

bonjour

merci pour ton aide , mais ça n'a l'air de fonctionner sur mon fichier. mais j'ai trouver une solution simple

cordialement

Philippe

Sub tirage_aleatoire()

Dim leTirage As Object, nbInscrits As Integer

Set leTirage = CreateObject("Scripting.Dictionary")
nbInscrits = Sheets("tirage").Range("E2")

Sheets("tirage").Range("A10:A610").ClearContents

While leTirage.Count < nbInscrits
    Randomize Timer
    Nbr = Int((nbInscrits - 1 + 1) * Rnd + 1)

    leTirage(Nbr) = Nbr
Wend

Sheets("tirage").Range("A10").Resize(leTirage.Count) = Application.Transpose(leTirage.Items)

End Sub  

Bonjour,

Bravo à vous !

Et merci de faire profiter à tout le monde votre nouveau code

@ bientôt

LouReeD