Modification de code pour avoir une répartition equitable

Bonjour,

dans le fichier ci-joint je n'arrive pas a faire une répartition équitable,

Pouvez vous svp me filer un petit coup de main

Je vous remercie pour votre aide

Bonjour

Un essai à tester. Te convient-il .

Bye !

Oups !

Annule et remplace la version précédente.

Bye !

Bonjour tout le monde,

Une autre proposition :

Bonsoir

merci à tous les 2 pour vos réponses

Bonne soirée

Re bonsoir

Optimix je reviens sur ta proposition tu verra qu'il y a un problème car la cellule Noms apparait

dans le tirage au sort,ce qui n'est pas logique chez cherché mais pas trouvé le hic

Effectivement. Il faut remplacer 1 par 2 sur la ligne

tirage = Int(Rnd() * nbEquipes) + 1

bonjour le fil

une autre proposition

Sub TirageDesPoules()
     Dim aA
     aA = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Value 'vos villes
     For i = 1 To UBound(aA) - 1
          r = WorksheetFunction.RandBetween(i, UBound(aA)) 'élément aléatoire
          x = aA(i, 1)
          aA(i, 1) = aA(r, 1) 'echanger les 2
          aA(r, 1) = x
     Next

     Set c = Range("U2:AE8")
     c.ClearContents
     k = 1
     For i = 1 To c.Rows.Count
          For j = 1 To c.Columns.Count Step 2
               c.Cells(i, j) = aA(k, 1)
               k = k + 1
               If k > UBound(aA) Then Exit Sub
          Next j
     Next i

End Sub

Bonjour

Merci cela fonctionne

Bonne journée

Bonne journée à vous deux et @+