Tirage aléatoire en VBA

Bonjour je suis a la recherche d'un code vba pour effectuer un tirage aléatoire

Explications dans le fichier ci-joint

Merci pour votre aide

Salut Joco7915,

À tester :

Sub Aleatoire()

    Dim plage1 As Range, plage2 As Range, plage3 As Range, plage4 As Range
    Dim multPlage As Range, cel As Range, alea As Byte, som As Byte

    Set plage1 = Range("D10:D18"): Set plage2 = Range("E5:E9")
    Set plage3 = Range("G10:G18"): Set plage4 = Range("H5:H9")

    Set multPlage = Union(plage1, plage2, plage3, plage4)
    multPlage.Value = ""

    Randomize
    For Each cel In multPlage
1     alea = WorksheetFunction.RandBetween(11, 38)
    som = Application.WorksheetFunction.Sum(Application.CountIf(plage1, alea), Application.CountIf(plage2, alea), _
                                            Application.CountIf(plage3, alea), Application.CountIf(plage4, alea))
    If som Then GoTo 1 Else cel = alea
    Next

    Set plage1 = Nothing: Set plage2 = Nothing
    Set plage3 = Nothing: Set plage4 = Nothing
    Set multPlage = Nothing

End Sub

Salut Joco,
Salut Baboutz,

je suppose, mais je n'en ai coupablement pas tenu compte, que les Range jaunes délimitaient les affichages aléatoires.
À revoir, donc...
Bien vu, Baboutz, le RandBetween : pas du tout pensé à ça, aujourd'hui...
Un double-clic sur la feuille démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab(), iRowT%, iNum%, iOK%
'
Cancel = True
iNb = Range("B" & Rows.Count).End(xlUp).Row - 14
For x = 1 To 4
    iOK = 0
    Randomize
    ReDim tTab(1 To iNb)
    Range(Choose(x, "D", "E", "G", "H") & IIf(x Mod 2 = 1, 10, 5)).Resize(Range(Choose(x, "D", "E", "G", "H") & Rows.Count).End(xlUp).Row, 1).Value = ""
    Do
        iNum = Int(Rnd * iNb) + 1
        If tTab(iNum) = 0 Then _
            iOK = iOK + 1: _
            tTab(iNum) = 1: _
            iRowT = IIf(Range(Choose(x, "D", "E", "G", "H") & IIf(x Mod 2 = 1, 10, 5)).Value = "", _
                IIf(x Mod 2 = 1, 10, 5), _
                Range(Choose(x, "D", "E", "G", "H") & Rows.Count).End(xlUp).Row + 1): _
            Range(Choose(x, "D", "E", "G", "H") & iRowT).Value = Range("B" & 14 + iNum).Value
    Loop Until iOK = iNb
Next
'
End Sub

A+

Bonjour à vous deux

Merci pour votre implication à ma demande.

J'ai retenu le fichier de Baboutz exactement ce que je souhaitais.

Bonne journée

Cordialement

Salut Joco7915, Curulis,

@Curulis : Je pense que tu as plus de mérite que moi, j'avoue être allé sur internet pour regarder les fonctions alea de VBA que j'utilise peu et que j'avais oublié

@Joco7915: Super Joco !

Bonne journée à vous deux,

Baboutz

bonjour a tous

juste en passant

Sub Aleatoire()
    Dim multPlage As Range, cel As Range, alea As Byte
    With feuil2: Set multPlage = Union(.[D10:D18], .[E5:E9], .[G10:G18], .[H5:H9]): End With
    multPlage.Value = ""
    Randomize
    For Each cel In multPlage
1       alea = WorksheetFunction.RandBetween(11, 38)
        If multPlage.Find(alea, , , xlWhole) Is Nothing Then cel = alea Else GoTo 1
    Next
    Set multPlage = Nothing
End Sub

Bonjour Patrick,

Habile ! Plus court en effet ! Merci

Salut Joco,
Salut l'équipe,

je n'ai certes pas plus de mérite que n'importe qui, Baboutz : moi aussi, je pioche souvent des infos sur la Toile. Je n'ai ps la science infuse et, parfois, comme ici avec RandBetween, la mémoire ou la jugeotte me font défaut !
Ton approche était la meilleure car tu as compris et tenu compte de la demande de Joco.

Par contre, PatrickToulon, je déteste les Goto, héritage des lointaines origines du Basic.
Ceci aurait été plus élégant !

Set rCells = Union([D10:D18], [E5:E9], [G10:G18], [H5:H9])
rCells.Value = ""
Randomize
For Each rCel In rCells
    Do
        iNb = WorksheetFunction.RandBetween(11, 38)
    Loop Until rCells.Find(iNb, , , xlWhole) Is Nothing
    rCel = iNb
Next
Set rCells = Nothing

A+

@Curulis ... joli !

Faudrait contrôler qu'l y a assez de place pour tous les nombres ? exemple

iNb = WorksheetFunction.RandBetween(deb, rcells.Count + deb - 1)

avec une valeur de deb

Ahah merci

Propre @Curulis... On ne pense pas assez à utiliser Do.. Loop, bravo !

@Curulis,

est-ce qu'un scripting.dictionary ne serait pas plus rapide que rCells.Find(iNb, , , xlWhole) ?

Je me suis posé la question Steelson, mais je n'ai pas encore eu l'occasion d'essayer !

Bonjour,

pour optimiser le tirage, éviter de tirer des nombres déjà tirés.

Sub tirage1()
    'mélange aléatoire des nombres de 1 à 999999

    Dim n(1 To 999999, 1 To 1) As Long, i As Long, a As Long, q As Long, fin As Long
    Dim t As Double
    t = Timer
    For i = 1 To UBound(n)
        n(i, 1) = i
    Next
    For i = 1 To UBound(n)
        fin = UBound(n) - i + 1
        'q=application.randbetween(1,fin) 'à remplacer par l'instruction suivante cfr message Baboutz ci-dessous.
        q = Int(Rnd() * fin + 1)
        a = n(q, 1)
        n(q, 1) = n(fin, 1)
        n(fin, 1) = a
    Next i
    Range("A1").Resize(UBound(n), 1) = n
    MsgBox Timer - t
End Sub

Steelson a écrit :

scripting.dictionary est peut-être un peu luxueux car ce ne sont qu'une suite de nombres continus, donc un simple tablo(1 to n) suffirait
je vais essayer avec 999999 nombres

résultat de l'essai = non ce n'est pas mieux avec dico dès que le nombre devient élevé !

pas mieux non plus (mais meilleur que dico) avec un tableau témoin,

the winner is h2so4 d'environ 1/3 (17secondes chez moi versus 27secondes)

rebonjour à tous,

autre méthode,

Sub tirage()
    t = Timer
    Range("A1") = 1
    Range("A2") = 2
    Range("A1:A2").AutoFill Range("A1:A999999")
    With Range("B1").Resize(999999, 1)
        .Formula = "=rand()"
        .Value2 = .Value2
    End With
    Range("A1").Resize(999999, 2).Sort Range("B1"), xlAscending, Header:=xlNo
    Columns("B").Delete
    MsgBox Timer - t
End Sub

5 secondes ...

Salut à tous,

Bravo h2so4 pour te deux contributions ! Voici une macro encore plus rapide, 1,2s chez moi contre 3,7 pour la dernière de h2so4 :

Sub mcs()
    Dim arListe(1 To 999999) As Long
    Dim arOut(1 To 999999, 1 To 1)
    Dim i As Long, r As Long
    t = Timer

    For i = 1 To 999999
        arListe(i) = i
    Next i

    For i = 999999 To 1 Step -1
        r = Int((i * Rnd) + 1)
        arOut(i, 1) = arListe(r)
        arListe(r) = arListe(i)
    Next i

    Range("A1").Resize(UBound(arOut)) = arOut
    MsgBox Timer - t
End Sub

J'ai un beaucoup moins de mérite, car je ne l'ai pas fait moi-même mais je l'ai trouvé sur un forum allemand (ici)

bonjour,

cette instruction semble faire toute la différence

q = Int(Rnd() * i + 1)

10 fois plus rapide que

q = Application.RandBetween(1, i)

(voir ma première proposition, qui fort semblable à celle trouvée par Baboutz)

bonjour

c'est normal utiliser les worksheetfunction peuvent etre lourdes rnd est natif en vb pas de librairie externe a visualbasic