vincent noah
XLDnaute Junior
Bonjour à tous !
je souhaite croiser deux code (proposé gentillement par job75) pour que le premier tir aléatoirement et sans doublons un nombre défini de tirage ex: 10
qui sont colorier en bleu.
en suite à partir du dixième tirages .on continu uniquement sur les cellules non colorée jusqu'à ce qu'une cellule contient un 5 ou un 4 ... c'est pas facile de l’expliquer j'ai essayer mais sans succès me parait très difficile . 1er code :
.
et le deuxième:
voilà j'espère que j'ai étais claire
MERCI pour toute aides .
je souhaite croiser deux code (proposé gentillement par job75) pour que le premier tir aléatoirement et sans doublons un nombre défini de tirage ex: 10
qui sont colorier en bleu.
en suite à partir du dixième tirages .on continu uniquement sur les cellules non colorée jusqu'à ce qu'une cellule contient un 5 ou un 4 ... c'est pas facile de l’expliquer j'ai essayer mais sans succès me parait très difficile . 1er code :
.
Code:
Private Sub Worksheet_Calculate()
Dim r As Range, limite, decharge&, nc&, d As Object
Dim c As Range, bleu As Range, n&
Set r = [A1:A30]
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
Code:
Sub Tirage()
Dim r As Range, cible, ncoul As Range, nc&, d As Object, c As Range
Set r = [A1:A30] 'plage à adapter
cible = 4 or 5 'à adapter
Set ncoul = [E2]'nombre de tirages total
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
voilà j'espère que j'ai étais claire
MERCI pour toute aides .