Discussion :

[halaster08]

Bonjour,

Etant absent au dernier tournoi de mon asso, j'ai fait rapidemment un classeur pour la gestion des points.
J'aimerais maintenant améliorer ce classeur (et le partager ici au cas où ça intéresse qqn) de manière à ce qu'il soit simple d'utilisation et applicable a d'autre jeux que celui pour lequel il a été conçu à la base.

Le principe est simple, on rempli la liste des inscrits, le nombre de tables, la maccro remplit alors les tables aléatoirement avec les inscrit.
L'orga n'a plus qu'a écrire le score et la position(1er 2eme ...) de chaque personne a chaque manche, le reste se calcule tout seul.
Il y a deux manières de gagner des points de tournoi, suivant la position (7pts pour le 1er, 5 le 2eme, 4, 3, ...) et suivant le score (1/10 arrondi inf)

Ce que j'aimerais améliorer pour l'instant:
-Calcul automatique de la position par table, avec le nombre de joueurs et de tables inconnu à la base j'ai du mal à trouver un algo pour calculer la position

Pour ceux qui veulent y jeté un oeil, le classeur est en PJ, et voici le code:

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
65
66
Sub alea()
Application.ScreenUpdating = False
Columns("A:A").Copy
Sheets("Points").Range("A1").PasteSpecial
dl = Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(2, 2), Cells(dl, 2)).FormulaR1C1 = "=RAND()"
 
ActiveWorkbook.Worksheets("Liste des inscrit").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Liste des inscrit").Sort.SortFields.Add Key:=Range _
        ("B2:B" & dl), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Liste des inscrit").Sort
        .SetRange Range("A1:B" & dl)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("A:A").Copy
    Sheets("Manche 1").Range("A1").PasteSpecial
    Application.CutCopyMode = False
Application.Calculate
ActiveWorkbook.Worksheets("Liste des inscrit").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Liste des inscrit").Sort.SortFields.Add Key:=Range _
        ("B2:B" & dl), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Liste des inscrit").Sort
        .SetRange Range("A1:B" & dl)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("A:A").Copy
    Sheets("Manche 2").Range("A1").PasteSpecial
    Application.CutCopyMode = False
    n = Range("table")
    reste = (dl - 1) Mod n
    Dim taille(5) As Integer
    For i = 0 To n - 1
        taille(i) = Application.WorksheetFunction.RoundDown((dl - 1) / n, 0)
    Next i
    For j = 0 To reste - 1
        taille(j) = taille(j) + 1
    Next j
For i = n - 2 To 0 Step -1
         taille(i) = taille(i) + taille(i + 1)
Next i
taille(0) = taille(0) - 1
For i = n - 1 To 0 Step -1
On Error Resume Next
Debug.Print dl - taille(i)
    Sheets("Manche 1").Cells(dl - taille(i), 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Manche 1").Cells(dl - taille(i), 1) = "table " & n
    Sheets("Manche 2").Cells(dl - taille(i), 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Manche 2").Cells(dl - taille(i), 1) = "table " & n
    n = n - 1
On Error GoTo 0
Next i
 
Columns(2).EntireColumn.Delete
Application.ScreenUpdating = True
 
End Sub

edit: problème avec mes images jointes
Sur les feuilles de score après le passage de la maccro on a:
dans la colonne A:
table1
joueur 1
...
joueur n
table 2
joueur n+1
..
joueur m
table 3
...

le score se rentre dans la colonne D et la position dans la B