Discussion :

[youlig]

Bonsoir,

J'ai récupéré sur le net un code vba pour un tirage au sort aléatoire pour une compétition sportive.

En fait une fois le tirage au sort réalisé, les n°s des équipes apparaissent sur la même feuille dans les colonnes suivantes (ex: colonne F ligne 4, la 1ère équipe du GR.A, ligne 5, la 2ème du GR.B ..... colonne H ligne 4 la 1ère équipe du GR.B ..... etc)

J'aimerais pouvoir afficher directement les équipes dans leur groupe sur une autre feuille (1 feuille pour le GR.A, 1 pour le GR.B....), c'est pour cela que je fais appelle à vous afin de m'expliquer le morceau de code qui suit afin que je puisse essayer de l'adapter à ma volonté.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
k = 1
For Lig = 4 To NbEquipesGroupe + 3
    For Col = 6 To NbGroupes * 2 + 5 Step 2
    On Error Resume Next
    If Err.Number = 0 Then
    .Cells(Lig, Col) = TabPts(k, 1)
    k = k + 1
    End If
    On Error GoTo 0
    Next Col
Next Lig

Merci d'avance pour les personnes qui me consacreront du temps.

[youlig]

Bonjour à tout le forum,

Voici la macro complète, peut être que le bout de code que je vous avais transmis n'est pas suffisant, ainsi que le fichier.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Sub TiragePoules()
Dim Derlig As Integer, TabPts, NbEquipes As Integer, Col As Byte, Lig As Byte, N As Integer, I As Integer, J As Integer, k As Integer, Temp
Dim Tirage As Integer, Coll As Collection, NbGroupes, NbEquipesGroupe
 
' Désactivation de l'affichage
Application.ScreenUpdating = False
With Sheets("Tirage Groupes")
.EnableSelection = xlNoRestrictions
.Unprotect Password:="50points"
' Effacement du tirage précédent
.Range("F4:Z100").ClearContents
' Mise en tableau des équipes
Derlig = .Range("A65536").End(xlUp).Row
TabPts = .Range("A4:B" & Derlig)
NbGroupes = .Range("C2").Value
NbEquipesGroupe = .Range("D2").Value
NbEquipes = Derlig - 3
' Vérification d'un nombre d'équipes insuffisant
If NbEquipes < NbGroupes - 1 * NbEquipesGroupe Then
MsgBox "Le nombre d'équipes est insuffisant pour le nombre de groupes et d'équipes par groupe !"
' nombre d'équipes participantes supérieur au produit du nombre de groupes par celui du nombre d'équipes par groupe
ElseIf NbEquipes > NbGroupes * NbEquipesGroupe Then
MsgBox "Le nombre d'équipes est supérieur au produit du nombre de groupes par celui des équipes par groupe !"
End If
' tirage des équipes
Set Coll = New Collection
N = 0
Do
Tirage = Int((Rnd * NbEquipes) + 1)
On Error Resume Next
Coll.Add Tirage, CStr(Tirage)
On Error GoTo 0
If Coll.Count > N Then
N = Coll.Count
TabPts(N, 2) = Coll(Coll.Count)
End If
Loop Until Coll.Count = NbEquipes
' Mise en ordre croissant du tirage
ReDim Temp(1 To 1, 1 To 2)
For I = 1 To UBound(TabPts, 1)
    For J = I + 1 To UBound(TabPts, 1)
    If TabPts(J, 2) < TabPts(I, 2) Then
    Temp(1, 1) = TabPts(I, 1): Temp(1, 2) = TabPts(I, 2)
    TabPts(I, 1) = TabPts(J, 1): TabPts(I, 2) = TabPts(J, 2)
    TabPts(J, 1) = Temp(1, 1): TabPts(J, 2) = Temp(1, 2)
    End If
    Next J
Next I
' Affichage des participants dans le tableau des Poules
k = 1
For Lig = 4 To NbEquipesGroupe + 3
    For Col = 6 To NbGroupes * 2 + 5 Step 2
    On Error Resume Next
    If Err.Number = 0 Then
    .Cells(Lig, Col) = TabPts(k, 1)
    k = k + 1
    End If
    On Error GoTo 0
    Next Col
Next Lig
.EnableSelection = xlUnlockedCells
.Protect Password:="50points", Contents:=True, UserInterfaceOnly:=True, Scenarios:=True
End With
End Sub

[youlig]

Bonjour,

De l'aide, Merci !!!