Comment eviter des doublons lors d'un tirage au sort

Bonjour,

Le titre résume un peu le problème que je retrouve dans le fichier joint.

J'aimerais que lors du tirage 2 équipes d'un même club ne puissent s'affronter.

Je vous remercie pour votre aide

Bonjour,

Veuillez trouver ci-joint une macro alternative, utilisant une liste et une fonction pour vérifier si les groupes correspondent.

Bonjour,saboh12617

Merci pour ton aide mais ça ne fonctionne pas

excel mouline sans arrêt message excel ne répond pas

Crdlt

Bonjour à tous ,

Me revoilà avec mon problème de doublons

Même en changeant de code vba pour effectuer le tirage cela ne va pas

Dans le fichier joint j'ai précisé ce qui ne devait pas se produire

Si quelqu'un à une solution je suis preneur

Crdlt

re

bonjour

c'est pourtant simple dans une configuration ou tu a 2 colonnes (club/joueur)il ne faut pas tirer au sort il faut mélanger

le résultat sera le même sauf qu'il sera impossible d'avoir des doublon

d'ailleurs d"ans ton exemple de resultat avec doublon ca ne peut être que t"a macro c"ar en l'occurence ici tu n'a pas 2 joueurs d'un même groupe d"ans ta liste

et tu te retrouve avec 2doublons groupe

une toute petite macro de rien du tout

Sub tirage()
    Dim TbL, SeriE, i&, x, temp
    TbL = Range("A2", Cells(Rows.Count, 3).End(xlUp)).Value 'le tableau complet
    SeriE = Application.Index(TbL, , 1) 'la colonne des index
    For i = 1 To UBound(SeriE)
re:
        x = 1 + (Rnd * (UBound(SeriE) - 1))
        If SeriE(x, 1) = TbL(i, 1) Then GoTo re
        temp = SeriE(i, 1): SeriE(i, 1) = SeriE(x, 1): SeriE(x, 1) = temp
    Next
    [i2].Resize(UBound(TbL), 3) = Application.Index(TbL, SeriE, Array(1, 2, 3))
End Sub

a moins que je n'ai pas compris ta demande au quel cas il faut mettre de l'ordre et exprimer la demande clairement

dans n'importe quel cas ici je montre que je n'ai pas de doublons avec le mélange et non un tirage au sort

le tirage en fait et le tirage de l'index qui va être interverti avec l'index i

et pour pas que l'on tombe sur le même index dans le tableau de base par rapport au tableau unordoredce qui me permet non seulement de ne pas avoir de doublons dans mon tirage mais aussi que chaque item ne soit pas sur la même ligne que le tableau de base

Bonjour

Si tu peux m'expliquer comment faire ,alors je suis preneur

Parce que là je n'y comprend rien

Désolé

Cordialement

j'ai edité mon message

Bonjour,

Patrick A ce que j'ai compris notre ami veut éviter que deux équipes de l'OL ou du PSG jouent entre elles.

Pas la peine de faire 300 km pour faire jouer OL1 contre OL2 ou PSG1 contre PSG3...

A+

re

bonjour galopin

c'est bien ce que je pensais

bien mal pensé ce truc

la on est a 12 lignes et on a déjà 2 même groupes sous une appellation différente

si ol1 et ol2 c'est la même chose que va t il advenir quand on aura 500 lignes et des dizaines de doublons (trucmuche1,trucmuche2,trucmuche3,etc)

a moins d'avoir une table de références, désignant les appellations différentes comme identiques vous n'arriverez jamais a faire quelque chose de perenne

ca ne va faire ques codes alambiqués qui ne seront jamais à 100% surs

au contraire moi je laisserais les noms de club sans l'extension numérique

à essayer ceci en enlevant les extension numériques des noms de club

Sub tirage()
    Dim TbL, SeriE, i&, x, temp
    Randomize
    TbL = Range("A2", Cells(Rows.Count, 3).End(xlUp)).Value 'le tableau complet
    SeriE = Application.Index(TbL, , 1) 'la colonne des index
    For i = 1 To UBound(SeriE)
re:
        x = 1 + (Rnd * (UBound(SeriE) - 1))
        If SeriE(x, 1) = TbL(i, 1) Or _
               Trim(TbL(SeriE(x, 1), 2)) = Trim(TbL(i, 2)) Then GoTo re
        temp = SeriE(i, 1): SeriE(i, 1) = SeriE(x, 1): SeriE(x, 1) = temp
    Next
    [i2].Resize(UBound(TbL), 3) = Application.Index(TbL, SeriE, Array(1, 2, 3))
End Sub

patrick

bonjour patrickT,galopin01,Joco7915,

moi, je le fais comme ceci

Bonjour à tous

Merci pour vos réponses

@PatrickT j'ai retenu ton exemple qui me parait le plus simple à mettre en place

@BsAlv Quand je test j'ai un bug

Merci à tous

Crdlt

De retour avec mes doublons fichier original

dans la colonne A les cellules en rouge signalent les doublons

Merci pour votre aide

Bonjour,

Moi quand c'est comme ça je laisse tomber VBA... (Quoi que !)

Mébon comme il n'y a que 59 rencontres possible , j'ai trové plus simple de préparer les 36 premières à la main....

Ça fait déjà 6 tours : Ça me parait déjà pas mal pour une seule journée sous ce soleil lunatique !

Si ça peut aider. Pas de doublons de match ni de rencontre entre même club

A+

Bonjour à tous, 🙂

Au vue de ton dernier fichier, il n'y a que 59 confrontations possibles avec les contraintes énoncées.

C'était juste pour passer dire bonjour en ce beau dimanche 😉

klin89

bonour le fil,

@Joco7915, un bug, cela me dit rien, c'était où ?

Voici une solution plus élaborée complètement en mémoire. On a 2 sets de données, le set "Joco" = poussez le bouton "Joco" et le set "40" = poussez le bouton "40", 3 equipes, dont 2 équipes de 10 et une équipe de 20 pour vraiment compliquer les choses.

Puis vous poussez sur le bouton "Macro"

Bonsoir
juste en passant
pourquoi aller chercher toutes les combinaisons possible alors qu'il nous en faut seulement le nombre d’équipe

la méthode de "mélange" reste la plus sure et la plus rapide

sauf si le nombres de doublons est supérieur à la moitié du nombre des équipes ,au quel cas là il n'y a évidemment pas de solution possible ça c'est sur

l'avantage c'est fait en un seul tours avec quelques rebonds(au cause du 2d critère qui est 2 equipes identiques)

je rappelle la méthode qui est tout a fait simple

un tableau
une boucle sur tout les lignes
dans la boucle inverser l'index i de Literation de la boucle avec un index rnd

avec cette méthode on a pas a ce soucier du rnd qui pourrait éventuellement(surement même ) pécher le même index
qu'importe si un index est déplacé x fois (c'est l'avantage de cette méthode )

un exemple avec un array de 1 a 20

'----------------------------------------------
'Sample use of fonction UnorderedMatrice fonction 
'created by patricktoulon for Excel forumer
'this function can be adapted to the needs regarding random draws
'we apply after the matrix in the original array or a clone
'----------------------------------------------
Sub test()
    Dim tbl
    tbl = Application.Transpose(Evaluate("row(1:20)")) 'un array de 1 à 20
    MsgBox Join(tbl, ",") & vbCrLf & "-------------" & vbCrLf & Join(UnordoredMatrice(tbl), ",")

    tbl = Array("toto", "titi", "riri", "fifi", "loulou")
    MsgBox Join(tbl, " - ") & vbCrLf & "-------------" & vbCrLf & Join(UnordoredMatrice(tbl), " - ")

End Sub

Function UnordoredMatrice(ByVal t)
    'created by patricktoulon
    Dim t2, x&, Temp '(temp est un variant car il peut servir pour des array texte ou nombre)
    Randomize
    t2 = t
    For i = LBound(t2) To UBound(t2)
        x = LBound(t2) + (Rnd * (UBound(t2) - LBound(t2))) 'devrait fonctionner en base 0 ou 1
        Temp = t2(i): t2(i) = t2(x): t2(x) = Temp
    Next
    UnordoredMatrice = t2
End Function

reste plus qu'a ajouter le rebond pour le 2d critère comme dans ma précédente démo

Bonjour,

Je reviens vers vous avec ma proposition revue. Effectivement le mix proposé par PatrickT me semble la solution la plus correcte d'un point de vue théorique, meme si au vu de la présentation des données je ne sais pas comment elle permet de gérer les Groupements d'équipes.

Ci-après le fichier et la macro en question. J'ai bien du mal à comprendre pourquoi mais le programme semble perdu sur les boucles et parfois indique une "erreur" simplement cliquer sur continuer permet de terminer sans problèmes. Une limite qu j'ai pu observer est que, une fois toutes les équipes attribuées sauf les 2 dernières, si ces deux dernières sont de meme "groupe" alors le programme lève l'erreur susmentionnée (mais il la lève aussi sans raisons, ce que j'ai plus de mal à comprendre). Dans tous les cas cliquer sur continuer permet de terminer la boucle, et au besoin il suffit de relancer si effectivement le cas se produit (plus simple selon moi qu'un gestion d'erreur avec un appel récursif à la macro).

Public Sub Tirage2()

  ' effacage anciens resultats
  ActiveSheet.Range("D:D").ClearContents

  Dim groupList As Object    ' 0: Group0 // key=team num, valeur=groupe name
  Set groupList = CreateObject("Scripting.Dictionary")
  groupList.CompareMode = vbTextCompare

  Dim i As Long
  For i = 1 To ActiveSheet.Cells(1, 2).End(xlDown).Row
    groupList.Add i, GetGroup2(i)
    'Debug.Print i, GetGroup2(i)
  Next i

  Dim avaliableTeams As Long
  avaliableTeams = groupList.Count

  Do While avaliableTeams > 0
    ' teamA retir�e de la liste
    Dim teamA As Long: teamA = groupList.Keys()(0)
    groupList.Remove teamA
    avaliableTeams = avaliableTeams - 1

    Dim teamB As Long, validation As Boolean
    Do
      teamB = groupList.Keys()(WorksheetFunction.RandBetween(0, groupList.Count - 1))
      validation = (GetGroup2(teamA) <> GetGroup2(teamB))
      'Debug.Print GetGroup2(teamA) & " vs " & GetGroup2(teamB) & " " & validation
    Loop Until validation

    ' teamB retir�e de la liste
    groupList.Remove teamB
    avaliableTeams = avaliableTeams - 1

    ' ecriture du resultat dans excel, colonne 4
    ActiveSheet.Cells(teamA, 4).Value2 = teamB
  Loop

End Sub

Private Function GetGroup2(ByVal teamIndex As Long) As String
  ' en supposant d�but des �quipes en ligne 1
  Dim fullName As String
  fullName = ActiveSheet.Cells(teamIndex, 2).Value2

  Dim i As Long
  For i = 0 To 9
    fullName = VBA.Replace(fullName, CStr(i), vbNullString)
  Next i

  GetGroup2 = VBA.Trim$(fullName)
End Function

re,

je ne crois pas que vous trouvez toujours une solution avec cette méthode !

J'ai vu mon bug, "Sequence" existe depuis 2021, donc j'ai du le faire autrement

PS. Si vous voulez échanger les 2 colonnes, ce n'est pas si difficile.

Bonjour

Merci à tous pour vos solutions.

Cordialement

Bonjour à tous,

Une autre approche qui arrivera après la bataille, mais où les équipes d'un même club ne se rencontrent jamais.
La 1ère rencontre s'inscrit dans le panel jaune.