tirage aléatoire par personne

Z

zizoufan

XLDnaute Occasionnel
Bonjour à tous

Je souhaiterais faire un tirage au sort aléatoire de 4 numéros par personne et les afficher.
Merci de votre aide
 

Pièces jointes

  • tirage_aleatoire.xlsx
    8.2 KB · Affichages: 32
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : tirage aléatoire par personne

Re,

Une solution VBA parmi d'autres :

Code: 
Sub Tirage()
Dim nlig&, d As Object, c As Range, i&, c1 As Range
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.EntireRow
  nlig = .Rows.Count
  .Columns("G").ClearContents 'RAZ
  Set d = CreateObject("Scripting.Dictionary")
  Randomize
  For Each c In .Columns("F").Cells
    i = Application.CountIf(.Columns("C"), c)
    For i = 1 To IIf(i < 4, i, 4)
      Do
        Set c1 = .Cells(Int(1 + nlig * Rnd), "D")
      Loop While c1(1, 0) <> c Or d.exists(c1.Value)
      d(c1.Value) = ""
      c(i, 2) = c1
    Next
  Next
End With
End Sub
Fichier joint.

A+
 

Pièces jointes

  • tirage_aleatoire par VBA(1).xlsm
    19.1 KB · Affichages: 24
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : tirage aléatoire par personne

Re,

De retour à Paris sur Excel 2003.

Voici une solution plus complète, la macro traite aussi les noms :

Code: 
Sub Tirage()
Dim deb As Range, P As Range, nlig&, d As Object
Dim c As Range, i&, c1 As Range
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
nlig = P.Rows.Count
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    deb = c
    i = Application.CountIf(P, c)
    For i = 1 To IIf(i < 4, i, 4)
      Do
        Set c1 = P(Int(1 + nlig * Rnd), 2)
      Loop While c1(1, 0) <> c Or d.exists(c1.Value)
      d(c1.Value) = ""
      deb(i, 2) = c1
    Next
    Set deb = deb(5)
  End If
Next
End Sub
Fichier (2).

A+
 

Pièces jointes

  • tirage_aleatoire par VBA(2).xls
    47 KB · Affichages: 23
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : tirage aléatoire par personne

Bonjour zizoufan, le forum,

La solution (2) précédente fonctionne bien s'il n'y a pas de doublons en colonne D (ID).

S'il y en a il faut les éliminer avec un 2ème Dictionary :

Code: 
Sub Tirage()
Dim deb As Range, P As Range, nlig&, d As Object
Dim c As Range, d1 As Object, c1 As Range, i As Byte
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
nlig = P.Rows.Count
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    deb = c
    Set d1 = CreateObject("Scripting.Dictionary")
    For Each c1 In P.Offset(, 1)
       If c1(1, 0) = c Then If Not d1.exists(c1.Value) Then d1(c1.Value) = ""
    Next
    For i = 1 To IIf(d1.Count < 4, d1.Count, 4)
      Do
        Set c1 = P(Int(1 + nlig * Rnd), 2)
      Loop While c1(1, 0) <> c Or d.exists(c1.Value)
      d(c1.Value) = ""
      deb(i, 2) = c1
    Next
    Set deb = deb(5) 'deb(i)
  End If
Next
End Sub
Fichier (2 bis).

A+
 

Pièces jointes

  • tirage_aleatoire par VBA(2 bis).xls
    48 KB · Affichages: 23
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : tirage aléatoire par personne

Re,

Ah mais voilà qui est beaucoup mieux car plus rapide, qu'il y ait des doublons ou pas :

Code: 
Sub Tirage()
Dim deb As Range, P As Range, d As Object, c As Range
Dim d1 As Object, c1 As Range, a, n&, i As Byte, x
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    deb = c
    Set d1 = CreateObject("Scripting.Dictionary")
    For Each c1 In P.Offset(, 1)
      If c1(1, 0) = c Then If Not d1.exists(c1.Value) Then d1(c1.Value) = ""
    Next
    a = d1.keys: n = d1.Count: d1.RemoveAll
    For i = 1 To IIf(n < 4, n, 4)
      Do
        x = a(Int(n * Rnd))
      Loop While d1.exists(x)
      d1(x) = ""
      deb(i, 2) = x
    Next
    Set deb = deb(5) 'deb(i)
  End If
Next
End Sub
Fichier (3).

PS : la solution (2 bis) ne va pas si un même ID est affecté à plusieurs noms.

A+
 

Pièces jointes

  • tirage_aleatoire par VBA(3).xls
    48 KB · Affichages: 20
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : tirage aléatoire par personne

Bonjour zizoufan, le forum,

Une solution par tableaux VBA (matrices), bien plus rapide sur de grands tableaux :

Code: 
Sub Tirage()
Dim ntirage, deb As Range, t, nlig&, d As Object, i&, x, a, h&, rest(), j&, b, n&
ntirage = 4 'paramétrable
Set deb = [F4]
t = Range("C4:D" & Range("C" & Rows.Count).End(xlUp)(2).Row) 'matrice
nlig = UBound(t)
Set d = CreateObject("Scripting.Dictionary")
'---noms sans doublons---
For i = 1 To nlig
  x = t(i, 1)
  If x <> "" Then d(x) = ""
Next i
If d.Count = 0 Then GoTo 1
'---tirage des ID---
a = d.keys: h = ntirage * d.Count
ReDim rest(1 To h, 1 To 2)
Randomize
For i = 0 To UBound(a)
  x = a(i)
  rest(ntirage * i + 1, 1) = x
  d.RemoveAll
  For j = 1 To nlig
    If t(j, 1) = x Then d(t(j, 2)) = ""
  Next j
  b = d.keys: n = d.Count: d.RemoveAll
  For j = 1 To IIf(n < ntirage, n, ntirage)
    Do
      x = b(Int(n * Rnd))
    Loop While d.exists(x)
    d(x) = ""
    rest(ntirage * i + j, 2) = x
  Next j
Next i
'---restitution---
deb.Resize(h, 2) = rest
1 deb.Offset(h).Resize(Rows.Count - deb.Row - h + 1, 2).ClearContents
End Sub
Fichier (4).

Edit : durées d'exécution des macros :

- fichier (3) => 6,8 millisecondes sur Win XP - Excel 2003 et 3,6 millisecondes sur Win 7 - Excel 2010

- fichier (4) => 1,7 milliseconde sur Win XP - Excel 2003 et 0,9 milliseconde sur Win 7 - Excel 2010

Je pense qu'on a fait le tour du problème.

A+
 

Pièces jointes

  • tirage_aleatoire par VBA(4).xls
    50 KB · Affichages: 23
Dernière édition:
Vote positif 0 Vote négatif
Z

zizoufan

XLDnaute Occasionnel
Re : tirage aléatoire par personne

job75 à dit:
Bonjour zizoufan, le forum,

Une solution par tableaux VBA (matrices), bien plus rapide sur de grands tableaux :

Code: 
Sub Tirage()
Dim ntirage, deb As Range, t, nlig&, d As Object, i&, x, a, h&, rest(), j&, b, n&
ntirage = 4 'paramétrable
Set deb = [F4]
t = Range("C4:D" & Range("C" & Rows.Count).End(xlUp)(2).Row) 'matrice
nlig = UBound(t)
Set d = CreateObject("Scripting.Dictionary")
'---noms sans doublons---
For i = 1 To nlig
  x = t(i, 1)
  If x <> "" Then d(x) = ""
Next i
If d.Count = 0 Then GoTo 1
'---tirage des ID---
a = d.keys: h = ntirage * d.Count
ReDim rest(1 To h, 1 To 2)
Randomize
For i = 0 To UBound(a)
  x = a(i)
  rest(ntirage * i + 1, 1) = x
  d.RemoveAll
  For j = 1 To nlig
    If t(j, 1) = x Then d(t(j, 2)) = ""
  Next j
  b = d.keys: n = d.Count: d.RemoveAll
  For j = 1 To IIf(n < ntirage, n, ntirage)
    Do
      x = b(Int(n * Rnd))
    Loop While d.exists(x)
    d(x) = ""
    rest(ntirage * i + j, 2) = x
  Next j
Next i
'---restitution---
deb.Resize(h, 2) = rest
1 deb.Offset(h).Resize(Rows.Count - deb.Row - h + 1, 2).ClearContents
End Sub
Fichier (4).

Edit : durées d'exécution des macros :

- fichier (3) => 6,8 millisecondes sur Win XP - Excel 2003 et 3,6 millisecondes sur Win 7 - Excel 2010

- fichier (4) => 1,7 milliseconde sur Win XP - Excel 2003 et 0,9 milliseconde sur Win 7 - Excel 2010

Je pense qu'on a fait le tour du problème.

A+
Cliquez pour agrandir...


Merci les gars pour vos solutions. En fait je n'ai besoin pour les doublons puisque ce sont des N° Uniques.
Mais ca pourrait servir qui sait :)
 
Vote positif 0 Vote négatif
Z

zizoufan

XLDnaute Occasionnel
Re : tirage aléatoire par personne

Bonjour à tous,

J'ajoute une petite complexité au problème :
- J'ai besoin de trier par date aussi de telle façon à ne pas avoir 2 ID de la même date.
- Une fois la restitution faite, envoyer à chaque sa liste des "ID" en se basant sur une liste de "mails"

Est ce possible ? Merci de votre aide précieuse. Il faut dire que j'ai essayé de comprendre le script mais en vain
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2021 macro pour faire un tirage au sort
Réponses
4
Affichages
200
marco22
M
M
  • Question
XL 2021 Créer une macro pour faire un tirage aléatoire d'un tournoi
Réponses
2
Affichages
204
marco22
M
P
  • Question
Microsoft 365 Tirage au sort tombola
Réponses
5
Affichages
268
patricktoulon
patricktoulon
A
  • Question
XL 2010 alea entre bornes sur une liste volatile
Réponses
1
Affichages
197
Dranreb
Dranreb
M
  • Question
XL pour MAC Report de valeur
Réponses
10
Affichages
217
JHA
J
D
  • Question
XL 2010 Tirage aléatoire d'équipes de 2
3 4 5
Réponses
67
Affichages
2 K
Dranreb
Dranreb
3
  • Question
XL 2010 liste de numéro sans les trouts
Réponses
2
Affichages
403
306255
3
R
  • Question
Microsoft 365 Tirage au sort
Réponses
2
Affichages
566
Modeste geedee
Modeste geedee
M
  • Question
Autres Récupération des noms + équipes dans une liste
Réponses
2
Affichages
157
DJunqueira
D
J
  • Question
XL 2016 macro dans cellule
Réponses
4
Affichages
193
jo50160
J

Membres actuellement en ligne

11 membres et 64 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 347
Messages
2 087 504
Membres
103 565
dernier inscrit
Fabien78