Modification pour tirage au sort 5 fois différents
Bonjour,
j'ai un code qui me permets de tirer au sort des données
Mais j'aimerais que ce code fasse 5 tirage et que aucune données
soit les mêmes au fur à mesure des tirages
(de façon 100% fiable)
Alors en resume
a chaque partie chaque "equipier" joue avec un autre equipier contre un autre duo d'equipier
Donc il faut tirer ces equipiers au sort mais a chaque aucun de ces equipiers ne doivent se retrouver dans les matchs d'après
les équipiers doivent aterrirent dans les colonnes C des tour 1-5
juste une précision les coéquipiers de peuvent pas joué 2 fois un contre l'autre et ni 2 fois ensemble
Merci d'avance
Sub tirage_automatique()
ReDim t(0)
For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If cel.Value <> "" Then
t(UBound(t)) = cel.Value
ReDim Preserve t(UBound(t) + 1)
End If
Next
ReDim Preserve t(UBound(t) - 1)
Set dico = CreateObject("scripting.dictionary")
Randomize
While dico.Count < UBound(t) + 1
x = Int((UBound(t) + 1) * Rnd)
dico(x) = t(x)
Wend
Range("C2").Resize(UBound(t) + 1) = Application.Transpose(dico.items)
End Sub
j'ai un code qui me permets de tirer au sort des données
Mais j'aimerais que ce code fasse 5 tirage et que aucune données
soit les mêmes au fur à mesure des tirages
(de façon 100% fiable)
Alors en resume
a chaque partie chaque "equipier" joue avec un autre equipier contre un autre duo d'equipier
Donc il faut tirer ces equipiers au sort mais a chaque aucun de ces equipiers ne doivent se retrouver dans les matchs d'après
les équipiers doivent aterrirent dans les colonnes C des tour 1-5
juste une précision les coéquipiers de peuvent pas joué 2 fois un contre l'autre et ni 2 fois ensemble
Merci d'avance
Sub tirage_automatique()
ReDim t(0)
For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If cel.Value <> "" Then
t(UBound(t)) = cel.Value
ReDim Preserve t(UBound(t) + 1)
End If
Next
ReDim Preserve t(UBound(t) - 1)
Set dico = CreateObject("scripting.dictionary")
Randomize
While dico.Count < UBound(t) + 1
x = Int((UBound(t) + 1) * Rnd)
dico(x) = t(x)
Wend
Range("C2").Resize(UBound(t) + 1) = Application.Transpose(dico.items)
End Sub
3 réponses
-
ContributeurBonjour
dim T()
T=Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).value 'renvoie un tableau de base 1
randomize
While dico.Count < 6 'tu demandes 5 tirages !
x = Int((UBound(t)) * Rnd)+1
ref=T(x)
if not dico.exists(ref) then dico.add ref,""
Wend
Range("C2").Resize(dico.count,1) = Application.Transpose(dico.keys)
Michel -
Bonjour,
dès que j'exécute la macro et la fenêtre me demande: Objet requis
en appuyant sur débogage ça me montre qu'il y a un problème ici:
While dico.Count < 6 'tu demandes 5 tirages !
Que dois-je faire?
Merci d'avance -
ContributeurBonjour,
Désolé, pas mal de trucs à faire cette semaine !
Option Explicit
Michel
Sub Selectionner_joueurs()
Dim Tablo(), Lig As Byte, Ref As String, Dico As Object, Joueurs()
Range("C2:C6").ClearContents
Set Dico = CreateObject("scripting.dictionary")
Tablo = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value 'renvoie un tableau de base 1
Randomize
While Dico.Count < 5 'tu demandes 5 tirages !
Lig = Int((UBound(Tablo)) * Rnd) + 1
Ref = Tablo(Lig, 1)
If Not Dico.exists(Ref) Then Dico.Add Ref, ""
Wend
Joueurs = Dico.keys
Range("C2").Resize(Dico.Count, 1) = Application.Transpose(Joueurs)
End Sub
