Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Crespo

XLDnaute Nouveau
Bonjour,

Je souhaiterais effectuer un tirage sans double avec des critères.

Ci-joint le fichier avec un exemple.

La colonne A peut être "flexible" avec moins ou plus d'éléments

Merci pour votre aide
 

Pièces jointes

1679522329691.png
10 boucles pour chaque methode
@Danreb, je sais, mais c'est trop de travail, on voit la différence déjà comme ça ...
Si nécessaire, on fait un teste avec 200k éléments (problème du transpose)
 

Pièces jointes

Dernière édition:
Bonjour à tous 🙂,

Moi aussi je veux jouer😜...
Un autre code sans doute très rapide aussi. il y a 20 000 lignes sources.
VB:
Sub TirageAleat()
Dim t, i&, j&, n&, aux, t0
   t0 = Timer: t = [a1].ListObject.DataBodyRange: ReDim r(1 To UBound(t) + 1, 1 To 3): Randomize
   For i = 1 To UBound(t): n = 1 + Int(Rnd * UBound(t)): aux = t(i, 1): t(i, 1) = t(n, 1): t(n, 1) = aux: Next i
   For i = 1 To UBound(t): n = Asc(Left(t(i, 1), 1)) - 64: r(UBound(t) + 1, n) = r(UBound(t) + 1, n) + 1: r(r(UBound(t) + 1, n), n) = t(i, 1): Next i
   Range("c2").Resize(UBound(t), 3) = r
   MsgBox Format(Timer - t0, "0.000 \sec.")
End Sub
 

Pièces jointes

Dernière édition:
Pas très compliqué pourtant :
VB:
Option Explicit
               #If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
               #Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
                  #End If
Private PerfoCtrDép As Currency
Sub DépartChrono()
   QueryPerformanceCounter PerfoCtrDép
   End Sub
Function SecondesChrono() As Double
   Dim PerfoCtrAct As Currency, Freq As Currency
   QueryPerformanceCounter PerfoCtrAct
   QueryPerformanceFrequency Freq
   SecondesChrono = (PerfoCtrAct - PerfoCtrDép) / Freq
   End Function
Sub Test()
   Application.Wait Now + TimeSerial(0, 0, 1)
   DépartChrono
   Application.Wait Now + TimeSerial(0, 0, 1)
   MsgBox SecondesChrono
   End Sub
 
je rajoute un peu de difficulté en rajoutant 2 onglets :

- onglet tirage 1er tour (j'aimerais qu'il se remplisse automatiquement => d'abbord on "vide" les equipes A un par pour poule, puis equipe B à la suite et equipe c )
- onglet poule reprend toutes les poules avec les matchs
 

Pièces jointes

Bonjour Crespo,

Ce n'est pas du tout clair.

Pour le 3ème onglet je ne comprends pas ce qu'il faut faire.

Pour l'onglet 'TIRAGE" les lettres des poules correspondent-elles aux lettres des équipes du 1er onglet ?

A+
En faite dans l'onglet "tirage" le poules doivent se remplir automatiquement en suivant l'ordre suivant des équipes "feuil1" : A, B, C
l'onglet "feuill3" doit dupliquer toutes les poules avec les matchs
 
En faite dans l'onglet "tirage" le poules doivent se remplir automatiquement en suivant l'ordre suivant des équipes "feuil1" : A, B, C
Bon voyez le fichier joint et le code de la feuille "TIRAGE" :
VB:
Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim c As Range, x$, crit$, n&, i&, a(), b
Randomize
Application.ScreenUpdating = False
With [Tableau1].ListObject.Range 'tableau structuré
    .Sort .Columns(1), xlAscending, Header:=xlYes 'tri du tableau
    For Each c In UsedRange
        If c = "N° Equipe" Then
            x = Trim(Replace(c(0, 0), "POULE", ""))
            crit = x & "*"
            n = Application.CountIf(.Columns(1), crit)
            c(2).Resize(4, 2) = "" 'RAZ
            If x <> "" And n Then
                ReDim a(1 To n)
                For i = 1 To n: a(i) = Rnd: Next i 'nombres aléatoires
                b = .Cells(Application.Match(crit, .Columns(1), 0), 1).Resize(n, 2) 'au moins 2 éléments
                tri a, b, 1, n
                With c(2).Resize(4)
                    .Value = b 'restitution
                    .Replace x, "", xlPart
                End With
            End If
        End If
    Next
End With
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g, 1): b(g, 1) = b(d, 1): b(d, 1) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub
Je ne sais pas où trouver les données pour remplir les zones "Noms Equipe".

Je ne m'occupe pas de la 3ème feuille.
 

Pièces jointes

Dernière édition:
Bon voyez le fichier joint et le code de la feuille "TIRAGE" :
VB:
Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim c As Range, x$, crit$, n&, i&, a(), b
Randomize
Application.ScreenUpdating = False
With [Tableau1].ListObject.Range 'tableau structuré
    .Sort .Columns(1), xlAscending, Header:=xlYes 'tri du tableau
    For Each c In UsedRange
        If c = "N° Equipe" Then
            x = Trim(Replace(c(0, 0), "POULE", ""))
            crit = x & "*"
            n = Application.CountIf(.Columns(1), crit)
            c(2).Resize(4, 2) = "" 'RAZ
            If x <> "" And n Then
                ReDim a(1 To n)
                For i = 1 To n: a(i) = Rnd: Next i 'nombres aléatoires
                b = .Cells(Application.Match(crit, .Columns(1), 0), 1).Resize(n, 2) 'au moins 2 éléments
                tri a, b, 1, n
                With c(2).Resize(IIf(n < 4, n, 4))
                    .Value = b 'restitution
                    .Replace x, "", xlPart
                End With
            End If
        End If
    Next
End With
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g, 1): b(g, 1) = b(d, 1): b(d, 1) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub
Je ne sais pas où trouver les données pour remplir les zones "Noms Equipe".

Je ne m'occupe pas de la 3ème feuille.
merci, mais ce n'est pas exctament ca, je le fais "manuellement" et vous renvoi le fichier
 
merci, mais ce n'est pas exctament ca, je le fais "manuellement" et vous renvoi le fichier
La difficulté est que le nombre équipe va fluctuer lors du tournoi (le nombre de poule sera calculé en fonction de nombre d'equipes) , on place les équipe qui commence par A puis B et les C complete
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
2
Affichages
36
Réponses
3
Affichages
327
  • Question Question
Microsoft 365 Power Query
Réponses
8
Affichages
112
Réponses
5
Affichages
49
Retour