Discussion :

[slevallois]

Bonjour, je voudrais mettre en place sur excel un programme pour créer automatiquement une feuille de saisie des résultats pour un concours de manille.
Le problème est qu'il y a bien longtemps que je n'ai plus programmé (plus de vingt ans) et je compte le faire avec VBA intégré sous excell.

Le nombre d'équipes serait ma première variable qui définirai un tableau ou matrice symétrique de cette dimension ou le score de chaque paire serait marqué. Bien entendu, aucun résultat ne peut être accepté sur la diagonale.
Ma deuxième variable serait le nombre de point pour une gagner une partie (ex 500) Puis il est nécessaire de faire le total pour chaque équipe afin de les classer.
Pour exemple le résultat aurait la forme suivante. on rentre 231, 269 est calculé par excell

e1 e2 e3 e4 .......total classement
e1 231
e2 269
e3 Un merci pour votre aide.

[rjamin]

Bonjour,
Pour qui n'est pas joueur de manille ce n'est pas très clair.
Il faudrait préciser les règles du jeu.
e1, e2, e3, e4 représente des équipes ou des joueurs?
Chaque équipe est constituée de combien de joueurs ?
Comment ce déroule le jeux une équipe contre une autre ?
Si j'ai bien compris il y a 500 points en jeux, si une équipe en obtient 231 l'autre à 500-231 et dans l'équipe la répartition ?

[pgz]

Bonjour.

C'est assez clair : l'opérateur saisi un score et dans la cellule symétrique il faut inscrire le complément à 500. La matrice est carrée mais certainement pas symétrique, puisque si e1 a marqué 231 contre e2, e2 a marqué 269 contre e1.

Il faut interdire la saisie sur la diagonale, puisque cela n'aurait aucun sens.

En suite on fait le total en ligne pour chaque équipe et un classement. Pour le classement, soit on indique un rang, soit il faut trier du 1er au dernier. Les 2 sont envisageables.

Cordialement,

PGZ

[slevallois]

C'est exact la matrice n'est pas symétrique mais carré. Les valeurs du bas sont en effet liées au résultats des rencontres entre les équipes.

Ee1, e2 désigne en effet les équipes.

J'ai déja créé la macro permettant l'affichage des intitulés (équipes) et noircit les valeurs de la diagonnales.

Je commence à créé celle pour permettre de reproduire la différence 500-la transposée.

J'aurai du utiliser (comme dans le temps) la structure de tableau (array) mais j'ai choisi une voix plus compliquée afin d'apprendre les rudiments de vba

Cela donne

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
Sub Macro3()
'
' Macro3 Macro
' Macro enregistrée le 27/05/2011 par Levallois
'
Dim b, a As String
nbequipe = InputBox("nombre d'équipes", "manille")
b = nbequipe + 1
a = "a" & b
 
Range("A2").Select
    ActiveCell.FormulaR1C1 = "e1"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "e2"
    Range("A2:A3").Select
    Selection.AutoFill Destination:=Range("A2", a), Type:=xlFillDefault
    Range("A2", a).Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
 
'met la diagonnale en noir
 
    Range("B2").Select
    For I = 1 To nbequipe
 
    With Selection.Interior
        .ColorIndex = 1
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    ActiveCell.Offset(1, 1).Activate
   Selection.Cut Destination:=ActiveCell
    Application.CutCopyMode = False
    Next I
End Sub

Je vous remercie si vous pouvez amméliorer cela avec un test sur la diag onnale par exemple.

remarque nbequipe a été défini par private nb équipe as integer car je vais m'en servir dans d'autre macro.

[mercatog]

Bonjour
Une proposition pour tracer ton gabarit

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
Sub Preparation()
Dim Rep As String
Dim NbEq As Integer, i As Integer
 
Rep = InputBox("Nombre d'équipes", "Manille")
NbEq = Int(Val(Rep))
If NbEq > 1 Then
    With Sheets("Feuil1") 'ADAPTE LE NOM DE TA FEUILLE
        .UsedRange.Clear
        For i = 1 To NbEq
            .Cells(i + 1, 1) = "E" & i
            .Cells(1, i + 1) = "E" & i
            .Cells(i + 1, i + 1).Interior.ColorIndex = 1
        Next i
    End With
End If
End Sub

Pour le remplissage de la moitié, utilise l'évènement Change de ta feuille. Bon, d'abord regarde les tutos et les rudiments pour pouvoir avancer.

[slevallois]

Je te remercie, c'est beaucoup plus clair que ma programmation et me laisse entrevoir la solution pour le remplissage des cellules.

Je me suis servi du programme précédent pour remplir les cellules.
les variables nbeq et nbp ont été définies aupréalable par private.

Le problème et de taille, c'est la macro calcul doit être activer à chaque fois que je rentre un nouveau score. J'ai pensé créer un bouton mais je ne trouve pas cela pratique. l'évènement change pour ma feuille me serait sûrement utile, mais je suis un peu perdu.

Un peu d'aide me serait bien utile.

Cordialement

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
Sub Preparation()
Dim Rep As String
Dim i As Integer
 
Rep = InputBox("Nombre d'équipes", "Manille")
nbeq = Int(Val(Rep))
nbp = InputBox("Nombre de point pour une partie", "Manille")
If nbp > 1 Then
If nbeq > 1 Then
    With Sheets("Feuil1") 'ADAPTE LE NOM DE TA FEUILLE
        .UsedRange.Clear
        For i = 1 To nbeq
            .Cells(i + 1, 1) = "E" & i
            .Cells(1, i + 1) = "E" & i
            .Cells(i + 1, i + 1).Interior.ColorIndex = 1
        Next i
    End With
End If
End If
 
End Sub
 
 
Sub calcul()
 
Dim i, j As Integer
With Sheets("Feuil1")
For i = 2 To nbeq + 1
For j = 2 To i
If .Cells(j, i) = 0 Then
.Cells(i, j).Interior.ColorIndex = 1
Else
.Cells(i, j) = nbp - .Cells(j, i)
.Cells(i, j).Interior.ColorIndex = 2
End If
Next j
Next i
End With
 
End Sub

[mercatog]

Exemple non commenté (l'explication plus tard).
Mettre en A1 le nombre de points (par exemple 500).
Remplir au fur et à mesure les cellules de ton tableau.

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbEq As Integer, NbPt As Integer
 
NbPt = Int(Val(Range("A1").Value))
NbEq = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
If NbEq > 1 And NbPt > 1 Then
    If Not Intersect(Target, Range(Cells(2, 2), Cells(NbEq, NbEq))) Is Nothing Then
        If Target.Count = 1 Then
            Application.EnableEvents = False
            If Target.Row = Target.Column Or Target.Value > NbPt Then
                Target.ClearContents
            Else
                Cells(Target.Column, Target.Row) = NbPt - Target
            End If
            Application.EnableEvents = True
        End If
    End If
End If
End Sub

[fab256]

Qu'est ce que t'en pense si on limitais la saisie a une partie du tableau et le reste sera calculé en fonction de cette partie avec formule?

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
Sub Preparation()
Dim NbEq, NbPoint, i, j As Integer
Dim CellOp,PtEqOp As String 
 
NbEq = InputBox("Nombre d'équipes", "Insérer le nombre d'équipes")
NbPoint = InputBox("Nombre de Points", "Insérer le nombre de points")
If NbEq > 1 Then
    With Sheets(1)  'ADAPTE LE NOM DE TA FEUILLE
        .UsedRange.Clear
        For i = 1 To NbEq
            .Cells(i + 1, 1) = "E" & i
            .Cells(1, i + 1) = "E" & i
            .Cells(i + 1, i + 1).Interior.ColorIndex = 1
            For j = i + 1 To NbEq
              CellOp = "R[" & (j - i) & "]C[-" & (j - i) & "]"
              PtEqOp = NbPoint & "-" & CellOp
              .Cells(i + 1, j + 1).FormulaR1C1 = "=IF(" & CellOp & "<>""""," & PtEqOp & ","""")"
            Next j
        Next i
    End With
End If
End Sub

[slevallois]

Un grand merci pour tout le monde, j'arrive bientôt au bout.

Je préfère la dernière solution, mais je vais me pencher un peu plus tard la proposition antérieure

[slevallois]

J'ai presque terminé. Il me reste plus qu'à mettre en place les tests pour la validité des cellules. Je voudrais reprendre les lignes de codes de M. Meratog,
mais je ne sais pas ou les mettre. Pour le moment voilà ce que cela donne.

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
67
68
69
' Macro enregistrée le 29/05/2011 par Levallois
'
Sub Preparation()
Dim Rep As String
Dim NbEq, NbPoint, i, j As Integer
 
NbEq = InputBox("Nombre d'équipes", "Insérer le nombre d'équipes")
NbPoint = InputBox("Nombre de Points", "Insérer le nombre de points")
If NbEq > 1 Then
    With Sheets(2)  
        .UsedRange.Clear
        For i = 1 To NbEq
            .Cells(i + 1, 1) = "E" & i
            .Cells(1, i + 1) = "E" & i
            .Cells(i + 1, i + 1).Interior.ColorIndex = 1
            For j = i + 1 To NbEq
              cellop = "R[" & (j - i) & "]C[-" & (j - i) & "]"
              PtEqOp = NbPoint & "-" & cellop
              .Cells(i + 1, j + 1).FormulaR1C1 = "=IF(" & cellop & "<>""""," & PtEqOp & ",""?"")"
            Next j
        Next i
        .Cells(NbEq + 2, 1) = "Total"
        .Cells(NbEq + 3, 1) = "nb de parties"
        .Cells(NbEq + 4, 1) = "classement"
        cellop = "R[-" & NbEq & "]C:R[-1]C"
        cellop1 = "R[-" & NbEq & "]C:R[-2]C"
        cellop2 = "R[-2]c[0]"
        cellop3 = "R[-2]C2:R[-2]C" & NbEq + 1
    .Cells(NbEq + 2, 2).FormulaR1C1 = "=sum(" & cellop & ")"
     .Cells(NbEq + 3, 2).FormulaR1C1 = "=count(" & cellop1 & ")"
     .Cells(NbEq + 4, 2).FormulaR1C1 = "=rank(" & cellop2 & "," & cellop3 & ")"
    End With
    With Range(Cells(NbEq + 2, 2), Cells(NbEq + 2, NbEq + 1))
  .Select
  .Interior.ColorIndex = 8
 
    End With
 
     Selection.FormulaR1C1 = "=SUM(" & cellop & ")"
    With Range(Cells(NbEq + 3, 2), Cells(NbEq + 3, NbEq + 1))
     .Select
     .Interior.ColorIndex = 7
     End With
     Selection.FormulaR1C1 = "=count(" & cellop1 & ")"
    With Range(Cells(NbEq + 4, 2), Cells(NbEq + 4, NbEq + 1))
    .Select
    .Interior.ColorIndex = 5
End With
Selection.FormulaR1C1 = "=rank(" & cellop2 & "," & cellop3 & ")"
End If
 
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbEq As Integer, NbPt As Integer
 
NbEq = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
If NbEq > 1 Then
    If Not Intersect(Target, Range(Cells(2, 2), Cells(NbEq, NbEq))) Is Nothing Then
        If Target.Count = 1 Then
            Application.EnableEvents = False
            If Target.Row = Target.Column Or Target.Value > NbPt Then
                Target.ClearContents
            End If
            Application.EnableEvents = True
        End If
    End If
End If
End Sub

Quand, j'execute Private Sub Worksheet, il m'ouvre la fenêtre d'execution des macros.

Comment faire pour que cela fonctionne.

Merci à Fab256 et Meratog pour leur aide.

[mercatog]

Private Sub Worksheet est une procédure qui ne nécessite pas d'être lancée. Elle se lance automatiquement à chaque changement de valeur d'une cellule ou plage de la feuille (contenu dans la variable Target)

Sur un classeur vide, mets ces 2 code dans le module de la feuille (ici nommée Feuil5 à adapter)

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
Sub Preparation()
Dim Rep As String
Dim NbEq As Integer, NbPoint As Integer, i As Integer
 
Rep = InputBox("Nombre d'équipes", "Insérer le nombre d'équipes")
NbPoint = InputBox("Nombre de Points", "Insérer le nombre de points")
NbEq = Int(Val(Rep))
If NbEq > 1 Then
    With Sheets("Feuil5")
        .UsedRange.Clear
        With .Range("A1")
            .NumberFormat = ";;;"
            .Value = Int(Val(NbPoint))
        End With
        For i = 1 To NbEq
            .Cells(i + 1, 1) = "E" & i
            .Cells(1, i + 1) = "E" & i
            .Cells(i + 1, i + 1).Interior.ColorIndex = 1
        Next i
        .Range(.Cells(NbEq + 2, 1), .Cells(NbEq + 4, 1)).Value = Application.Transpose(Array("Total", "Nb de parties", "Classement"))
        With .Range(.Cells(NbEq + 2, 2), .Cells(NbEq + 2, NbEq + 1))
            .FormulaR1C1 = "=SUM(R[-" & NbEq & "]C:R[-1]C)"
            .Interior.ColorIndex = 8
        End With
        With .Range(.Cells(NbEq + 3, 2), .Cells(NbEq + 3, NbEq + 1))
            .FormulaR1C1 = "=COUNTA(R[-" & NbEq + 1 & "]C:R[-2]C)"
            .Interior.ColorIndex = 7
        End With
        With .Range(.Cells(NbEq + 4, 2), .Cells(NbEq + 4, NbEq + 1))
            .FormulaR1C1 = "=RANK(R[-2]C,R[-2]C2:R[-2]C" & NbEq + 1 & ")"
            .Interior.ColorIndex = 5
        End With
    End With
End If
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NbEq As Integer, NbPt As Integer
 
NbPt = Int(Val(Range("A1").Value))
NbEq = Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
If NbEq > 1 And NbPt > 1 Then
    If Not Intersect(Target, Range(Cells(2, 2), Cells(NbEq, NbEq))) Is Nothing Then
        If Target.Count = 1 Then
            Application.EnableEvents = False
            If Target.Row = Target.Column Or Target.Value > NbPt Then
                Target.ClearContents
                Cells(Target.Column, Target.Row).ClearContents
            Else
                Cells(Target.Column, Target.Row) = IIf(Target.Value = 0, "", NbPt - Target)
            End If
            Application.EnableEvents = True
        End If
    End If
End If
End Sub

Lance la macro Preparation et commence par remplir les cellules.

[slevallois]

Merci, cela fonctionne très bien.

J'ai encore d'énorme progrès pour arriver à simplifier ma programmation.

Un grand merci à tous

cordialement