sélections de tirages

[vincent noah]

bonjour à tous ,


je cherche un code VBA , capable de tirer aléatoirement et sans doublons dans une liste de donnée.

le but étant de:
- colorier chaque cellule tirée.

- de s’arrêter lorsque le nb de tirages "max" est atteint

voila j'espère avoir était clair . .....

voici un fichier qui illustre ceux que je souhaite...


Merci d'avance

 

[job75]

Re : sélections de tirages

Bonjour vincent noah, le forum,

A tous je souhaite une excellente année 2015.

Voyez le fichier joint et cette macro :

Sub Tirage()
Dim deb As Range, nlig&, ncol%, limite, n, c As Range
Set deb = [A1] 'à adapter
nlig = 25: ncol = 2 'à adapter
limite = 10 'à adapter
deb.Resize(nlig, ncol).Interior.ColorIndex = xlNone 'RAZ
Randomize
While n < limite
  Set c = deb(Int(1 + Rnd * nlig), Int(1 + Rnd * ncol))
  If c.Interior.ColorIndex = xlNone Then
    n = n + 1
    c.Interior.ColorIndex = IIf(n < limite, 47, 3)
  End If
Wend
End Sub

A+

 

[job75]

Re : sélections de tirages

Re,

Dans le tableau A1:B25 il y a 4 doublons (144-155-210-276).

Si l'on veut les éviter dans les tirages, utiliser l'objet Dictionary :

Sub Tirage()
Dim r As Range, a$, nlig&, ncol%, limite, d As Object, c As Range
Set r = [A1:B25] 'plage à adapter
a = r.Address
nlig = r.Rows.Count: ncol = r.Columns.Count
limite = 10 'à adapter
r.Interior.ColorIndex = xlNone 'RAZ
If limite > Round(Evaluate("SUM(1/COUNTIF(" & a & "," & a & "))")) _
  Then MsgBox "Pas de solution, revoyez la limite !", 48: Exit Sub
Randomize
Set d = CreateObject("Scripting.Dictionary")
While d.Count < limite
  Set c = r(Int(1 + Rnd * nlig), Int(1 + Rnd * ncol))
  If Not d.exists(c.Value) Then
    d(c.Value) = ""
    c.Interior.ColorIndex = IIf(d.Count < limite, 47, 3)
  End If
Wend
End Sub

Fichier (2).

A+

 

[PMO2]

Re : sélections de tirages

Bonjour à tous et bonne année,

Une autre approche en utilisant l'objet Collection

Sub Tirages()
Dim Coll As New Collection
Dim Coll2 As New Collection
Dim C As Range
Dim R As Range
Dim i&
Dim x&
Dim nbTirages&
'---
If TypeName(Selection) <> "Range" Then Exit Sub
Selection.Interior.Color = xlNone
'---
nbTirages& = Application.InputBox _
              (prompt:="Indiquez le nombre de tirages", Type:=1)
'---
On Error Resume Next
For Each C In Selection
  Coll.Add CStr(C.Address), CStr(C.Value)
Next C
If nbTirages& > Coll.Count Then
  MsgBox prompt:="Vous avez demandé " & nbTirages& & _
          " tirages et on ne trouve que " & Coll.Count & " possibilités.", _
          Title:="Plage sélectionnée " & Selection.Address(False, False) & ""
  Exit Sub
End If
'---
Randomize Timer
Do
  x& = CLng((Coll.Count * Rnd) + 1)
  Coll2.Add Coll(x&), Coll(x&)
Loop Until Coll2.Count = nbTirages&
On Error GoTo 0
'---
For i& = 1 To Coll2.Count
  If R Is Nothing Then
    Set R = Range(Coll2(i&))
  Else
    Set R = Application.Union(R, Range(Coll2(i&)))
  End If
Next i&
'---
R.Interior.Color = vbCyan
Range(Coll2(Coll2.Count)).Interior.Color = vbRed
End Sub

 

[job75]

Re : sélections de tirages

Bonsoir Patrick, mes meilleurs vœux à toi aussi,

Si le tableau et le nombre limite sont grands, colorer les cellules en même temps après la boucle est nettement plus rapide :

Sub Tirage()
Dim r As Range, limite, nc&, a$, d As Object, c As Range, bleu As Range
Set r = [A1:B25] 'plage à adapter
limite = [D2] 'à adapter
nc = r.Count: a = r.Address
If limite > Round(Evaluate("SUM(1/COUNTIF(" & a & "," & a & "))")) _
  Then MsgBox "Pas de solution, revoyez la limite !", 48: GoTo 1
Randomize
Set d = CreateObject("Scripting.Dictionary")
While d.Count < limite
  Set c = r(Int(1 + Rnd * nc))
  If Not d.exists(c.Value) Then
    d(c.Value) = ""
    Set bleu = Union(c, IIf(bleu Is Nothing, c, bleu))
  End If
Wend
1 r.Interior.ColorIndex = xlNone 'RAZ
If c Is Nothing Then Exit Sub
bleu.Interior.ColorIndex = 47 'bleu
c.Interior.ColorIndex = 3 'rouge
End Sub

Fichier (3).

Edit : j'ai paramétré la limite en D2.

A+

 

[job75]

Re : sélections de tirages

Bonjour le forum,

Une variante avec le nom défini T, validation de données en D2 et formule volatile en E2 :

Private Sub Worksheet_Calculate()
Dim r As Range, limite, nc&, d As Object, c As Range, bleu As Range
Set r = [T]
limite = [D2]
nc = r.Count
Randomize
Set d = CreateObject("Scripting.Dictionary")
While d.Count < limite
  Set c = r(Int(1 + Rnd * nc))
  If Not d.exists(c.Value) Then
    d(c.Value) = ""
    Set bleu = Union(c, IIf(bleu Is Nothing, c, bleu))
  End If
Wend
r.Interior.ColorIndex = xlNone 'RAZ
If c Is Nothing Then Exit Sub
bleu.Interior.ColorIndex = 47 'bleu
c.Interior.ColorIndex = 3 'rouge
End Sub

Fichier (4).

Bonne journée.

 

[job75]

Re : sélections de tirages

Re,

Si la plage "bleu" à colorier est constituée de plusieurs milliers de cellules disjointes, le coloriage peut prendre beaucoup de temps.

Il faut alors procéder à une décharge, par exemple toutes les 500 cellules :

Private Sub Worksheet_Calculate()
Dim r As Range, limite, decharge&, nc&, d As Object
Dim c As Range, bleu As Range, n&
Set r = [T]
limite = [D2]
decharge = 500
nc = r.Count
r.Interior.ColorIndex = xlNone 'RAZ
Randomize
Set d = CreateObject("Scripting.Dictionary")
While d.Count < limite
  Set c = r(Int(1 + Rnd * nc))
  If Not d.exists(c.Value) Then
    d(c.Value) = ""
    Set bleu = Union(c, IIf(bleu Is Nothing, c, bleu))
    n = n + 1
    If n Mod decharge = 0 Then 'décharge
      bleu.Interior.ColorIndex = 47 'bleu
      Set bleu = Nothing
    End If
  End If
Wend
If Not bleu Is Nothing Then bleu.Interior.ColorIndex = 47  'bleu
If Not c Is Nothing Then c.Interior.ColorIndex = 3 'rouge
End Sub

Fichier (5).

A+

 

[vincent noah]

Re : sélections de tirages

Re ,

j'ais pris le deuxième code qui fonctionne bien sur une petite plage .Mais quand la plage sélectionnée est plus importante cela devient très très long .

une solution ??
ps: le code ne fonctionne pas si il arrive qu'une ou quelques cellules sont vide dans la première ou la deuxième colonne
Merci

 

[job75]

Re : sélections de tirages

Re,

A qui vous adressez-vous donc ?

Sur ce forum il est d'usage de saluer et remercier tous les contributeurs !

Pour les cellules vides c'est nouveau, il n'y en a pas sur votre fichier.

Et si vous voulez encore de l'aide donnez-nous plus de précisions :

- quelle plage devez-vous traiter exactement ?

- combien de cellules voulez-vous colorier ?

A+

 

[vincent noah]

Re : sélections de tirages

salut ....Re, job75

voilà j'ai réussi à détourner le pb ...
Mais j'aimerais avoir de l'aide car je souhaite modifier le code pour que :
les tirage ne s’arrête que lorsqu'un numéros précis est tiré
et un compteur m'affiche la somme des tirages à l’arrêt.

Merci d'avance

 

[job75]

Re : sélections de tirages

Re,

Pourquoi ne remerciez-vous pas aussi PMO2

Pour le nouveau problème posé voyez le fichier joint et cette macro :

Sub Tirage()
Dim r As Range, cible, ncoul As Range, nc&, d As Object
Dim c As Range, bleu As Range
Set r = [A1:B25] 'plage à adapter
cible = [D2] 'à adapter
Set ncoul = [E2] 'à adapter
If Application.CountIf(r, cible) = 0 Then _
  MsgBox "Valeur cible introuvable !", 48: GoTo 1
nc = r.Count
Randomize
Set d = CreateObject("Scripting.Dictionary")
Do
  Set c = r(Int(1 + Rnd * nc))
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    Set bleu = Union(c, IIf(bleu Is Nothing, c, bleu))
  End If
Loop While c <> cible
1 r.Interior.ColorIndex = xlNone 'RAZ
ncoul = ""
If c Is Nothing Then Exit Sub
bleu.Interior.ColorIndex = 47 'bleu
c.Interior.ColorIndex = 3 'rouge
ncoul = d.Count
End Sub

A+

 

[vincent noah]

Re : sélections de tirages

Salut , RE job 75

le code fonctionne bien sur une petite plage sélectionnée .
Mais sur une plage plus importante ....... j'ais lancé le tirage depuis au moin 10min et là j'attend toujours .
n'y a t-il pas moyen de gagner du temps ???

merci et à PMO2 au passage
a+

 

[job75]

Re : sélections de tirages

Re,

Sur une grande plage, comme je l'ai dit au post #7, il faut procéder à des décharges régulières.

Voyez ce fichier (2) avec 2 x 10000 cellules (sans doublons) :

Sub Tirage()
Dim r As Range, cible, ncoul As Range, decharge&, nc&
Dim d As Object, c As Range, bleu As Range
Set r = [A1:B10000] 'plage à adapter
cible = [D2] 'à adapter
Set ncoul = [E2] 'à adapter
decharge = 100 'ne pas dépasser 500
r.Interior.ColorIndex = xlNone 'RAZ
ncoul = ""
If Application.CountIf(r, cible) = 0 Then _
  MsgBox "Valeur cible introuvable !", 48: Exit Sub
nc = r.Count
Randomize
Set d = CreateObject("Scripting.Dictionary")
Do
  Set c = r(Int(1 + Rnd * nc))
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    Set bleu = Union(c, IIf(bleu Is Nothing, c, bleu))
    If d.Count Mod decharge = 0 Then 'décharge
      bleu.Interior.ColorIndex = 47 'bleu
      Set bleu = Nothing
    End If
  End If
Loop While c <> cible
If Not bleu Is Nothing Then bleu.Interior.ColorIndex = 47 'bleu
c.Interior.ColorIndex = 3 'rouge
ncoul = d.Count
End Sub

Bonne nuit et A+

 

[job75]

Re : sélections de tirages

Bonjour vincent noah, le forum,

En testant mieux je me rends compte que le coloriage différé avec décharges est inutile

Autant colorier les cellules une par une, voyez ce fichier (3) sur 2 x 20000 cellules :

Sub Tirage()
Dim r As Range, cible, ncoul As Range, nc&, d As Object, c As Range
Set r = [A1:B20000] 'plage à adapter
cible = [D2] 'à adapter
Set ncoul = [E2] 'à adapter
r.Interior.ColorIndex = xlNone 'RAZ
ncoul = ""
If Application.CountIf(r, cible) = 0 Then _
  MsgBox "Valeur cible introuvable !", 48: Exit Sub
Application.ScreenUpdating = False
Randomize
nc = r.Count
Set d = CreateObject("Scripting.Dictionary")
Do
  Set c = r(Int(1 + Rnd * nc))
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    c.Interior.ColorIndex = 47 'bleu
  End If
Loop While c <> cible
c.Interior.ColorIndex = 3 'rouge
ncoul = d.Count
End Sub

Bonne journée et A+

 

[job75]

Re : sélections de tirages

Re,

Il est possible que la vitesse d'exécution dépende de la version Excel utilisée.

Sur Excel 2010, sur un même fichier, il n'y a pas de différence entre les solutions des posts #13 et #14.

A voir sur Excel 2007.

A+