Modification code pour un range variable

[vincent noah]

Bonjour à tous ,

je cherche à modifier un code qui est très long quand il y a beaucoup de cellule à traiter !

* je souhaite que chaque cellule tirée (bleu) ne soit plus prise en compte pour le tirage suivant .... jusqu’à ceux que la cible soit atteinte.

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

*le code ma était gentillement proposé par job75.


Merci de votre aides

 

[job75]

Re : Modification code pour un range variable

Bonsoir vincent noah,

S'il s'agit de ne pas colorer les cellules en bleu c'est sûr qu'on va gagner du temps.

Et en plus on peut utiliser le tableau VBA t (matrice), ce qui accélère encore :

Sub Tirage()
Dim r As Range, cible, ncoul As Range, t, rc&, cc%, d As Object, i&, j%, x
Set r = [A1:B20000] 'plage à adapter
cible = [D2] 'à adapter
Set ncoul = [E2] 'à adapter
t = r 'matrice, plus rapide
r.Interior.ColorIndex = xlNone 'RAZ
ncoul = ""
If Application.CountIf(r, cible) = 0 Then _
  MsgBox "Valeur cible introuvable !", 48: Exit Sub
rc = r.Rows.Count: cc = r.Columns.Count
Set d = CreateObject("Scripting.Dictionary")
Randomize
Do
  i = Int(1 + Rnd * rc)
  j = Int(1 + Rnd * cc)
  x = t(i, j)
  If x <> "" Then d(x) = ""
Loop While x <> cible
r(i, j).Interior.ColorIndex = 3 'rouge
ncoul = d.Count
End Sub

Bonne fin de soirée et A+

 

[job75]

Re : Modification code pour un range variable

Re,

Cela dit, si l'on ne colore plus en bleu, le seul but est de colorer en rouge l'une des cellules égales à la valeur cible.

Il est donc inutile de faire des tirages aléatoires sur toutes les cellules du tableau :

Sub Tirage()
Dim r As Range, cible, ncoul As Range, n&, c As Range, i&
Set r = [A1:B20000] 'plage à adapter
cible = [D2] 'à adapter
Set ncoul = [E2] 'à adapter
r.Interior.ColorIndex = xlNone 'RAZ
ncoul = ""
n = Application.CountIf(r, cible)
If n = 0 Then _
  MsgBox "Valeur cible introuvable !", 48: Exit Sub
Randomize
n = Int(1 + Rnd * n)
Set c = r(1)
For i = 1 To n
  Set c = r.Find(cible, c, xlValues, xlWhole)
Next
c.Interior.ColorIndex = 3 'rouge
ncoul = n
End Sub

Bonne nuit.

 

[vincent noah]

Re : Modification code pour un range variable

Bonjour job75,

sur le dernier code il n'y a pas de tirage aléatoire

n'est-il pas possible de modifier le Range ? je souhaite garder le code de départ pour faire ceux-ci :

exemple : sur une plage (A1,B20) avec pour cible :5
-le tirage aléatoire donne le 3
-le but est que le 3 ne soit plus pris en compte pour les tirage suivant .. idem pour les numéros suivant jusqu'à ce que la cible soit atteinte



Merci de ton aides

 

[job75]

Re : Modification code pour un range variable

Bonsoir vincent noha,

J'ai bien l'impression, d'après ce que vous dites, que vous n'avez compris aucun des codes que j'ai proposés.

J'arrête donc là les frais.

Bonne continuation.

 

[job75]

Re : Modification code pour un range variable

Bonsoir,

La fin de l'histoire sur cet autre fil :

https://www.excel-downloads.com/threads/petit-coup-de-main.227938/

A+