tirage aléatoire

[Crespo]

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

 

[job75]

milliseconde ou seconde ???

Sur un si petit tableau, à votre avis ?

Pour mesurer le temps j'ai dû faire 1000 boucles.

 

[Dranreb]

Bonsoir.
Remarque: il est possible de chronométrer des traitements à l'unité avec les API QueryPerformanceCounter et QueryPerformanceFrequency

 

[bsalv]

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)

 

[mapomme]

Bonjour à tous ,

Moi aussi je veux jouer...
Un autre code sans doute très rapide aussi. il y a 20 000 lignes sources.

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

 

[Dranreb]

Pas très compliqué pourtant :

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

 

[bsalv]

1. mapomme 0.14
2. job75 0.17
3. bsalv 0.24
mes excuses à Job75, j'ai fait un erreur quelque part (#15&18)

 

[Crespo]

Merci a tous, je vais tester les 2 solutions ))

 

[sylvanu]

Bonjour Crespo, Job, Dranreb, Mapomme, Bsalv,
Une autre approche sans VBA ni formules matricielles.
Nécessite 3 colonnes ( qui sont masquées )

 

[Crespo]

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

 

[job75]

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+

 

[Crespo]

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

 

[job75]

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" :

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.

 

[Crespo]

Bon voyez le fichier joint et le code de la feuille "TIRAGE" :

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

 

[Crespo]

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

 

[job75]

Vous ne nous donnez pas la logique du remplissage.

Pourquoi B129 en I7 et B126 en M7 ?