Afin de tenir à jour les résultats & le classement d'un championnat de football, j'utilise naturellement le tableur openoffice.
Comme vous le verrez, à travers la pièce jointe, ma méthode est cependant assez fastidieuse.
Pour résumer, je rentre manuellement, dans un premier temps, le score du match, le nombre de journées, de buts pour, de buts contre, de victoire, de nuls et de défaites.
Par la suite, grâce aux formules contenues dans le "tableau-classement" (voir sur la droite de la feuille), j'ai une automation de ce classement.
Fastidieux, vous disais-je...
J'imagine que via des macros, il est possible que tout soit automatisé du simple moment où je rentre un score. Problème, je ne connais pas du tout ce monde de la macro.
Par conséquent, si quelqu'un a sous le coude un fichier-macro qu'il peut rapidement adapter (ou m'expliquer comment l'adapter) pour correspondre à ma feuille qu'il n'hésite pas à me répondre.
J'en ai trouvé une sous excel mais bien évidemment elle ne fonctionne pas sous Oo.
La voici ci-dessous :
Code : Tout sélectionner
Rem Attribute VBA_ModuleType=VBADocumentModule
Option VBASupport 1
Private Sub CommandButton1_Click()
Dim NomJoueur As String
Dim Équipe As String
Dim NbJoués As Byte
Dim Gagnés As Byte
Dim Nuls As Byte
Dim Perdus As Byte
Dim ButsPour As Integer
Dim BP As Integer
Dim ButsContre As Integer
Dim BC As Integer
Dim Joueurs As Byte
Dim Domi As Byte
Dim Exter As Byte
Dim Delta As Integer
'On défusionne les cellules
Range("L21:Q37").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("L21:Q37").Select
Selection.NumberFormat = "0.00"
With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 16
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
For Joueurs = 1 To 17
Range("B" & Joueurs + 1).Select
NomJoueur = ActiveCell.Value
Range("C" & Joueurs + 1).Select
Équipe = ActiveCell.Value
NbJoués = 0: Gagnés = 0: Nuls = 0: Perdus = 0
ButsPour = 0: ButsContre = 0
For Domi = 1 To 17
If Domi <> Joueurs Then
Range(Chr(67 + Domi) & Joueurs + 1).Select
If ActiveCell.Value <> "" Then
NbJoués = NbJoués + 1
BP = Mid(ActiveCell.Value, 1, InStr(1, ActiveCell.Value, "-") - 1)
BC = Mid(ActiveCell.Value, InStr(1, ActiveCell.Value, "-") + 1)
ButsPour = ButsPour + BP
ButsContre = ButsContre + BC
Delta = (BP - BC)
Select Case Delta
Case Is > 0
Gagnés = Gagnés + 1
Case 0
Nuls = Nuls + 1
Case Is < 0
Perdus = Perdus + 1
End Select
End If
End If
Next Domi
For Exter = 1 To 17
If Exter <> Joueurs Then
Range(Chr(67 + Joueurs) & (Exter + 1)).Select
If ActiveCell.Value <> "" Then
NbJoués = NbJoués + 1
BP = Mid(ActiveCell.Value, InStr(1, ActiveCell.Value, "-") + 1)
BC = Mid(ActiveCell.Value, 1, InStr(1, ActiveCell.Value, "-") - 1)
ButsPour = ButsPour + BP
ButsContre = ButsContre + BC
Delta = (BP - BC)
Select Case Delta
Case Is > 0
Gagnés = Gagnés + 1
Case 0
Nuls = Nuls + 1
Case Is < 0
Perdus = Perdus + 1
End Select
End If
End If
Next Exter
'On reporte les scores
Range("B" & Joueurs + 20).Select
ActiveCell.Value = NomJoueur
Range("C" & Joueurs + 20).Select
ActiveCell.Value = Équipe
Range("D" & Joueurs + 20).Select
ActiveCell.Value = (Gagnés * 3) + Nuls
Range("E" & Joueurs + 20).Select
ActiveCell.Value = NbJoués
Range("F" & Joueurs + 20).Select
ActiveCell.Value = Gagnés
Range("G" & Joueurs + 20).Select
ActiveCell.Value = Nuls
Range("H" & Joueurs + 20).Select
ActiveCell.Value = Perdus
Range("I" & Joueurs + 20).Select
ActiveCell.Value = ButsPour
Range("J" & Joueurs + 20).Select
ActiveCell.Value = ButsContre
Range("K" & Joueurs + 20).Select
ActiveCell.Value = ButsPour - ButsContre
If NbJoués > 0 Then
Range("L" & Joueurs + 20).Select
ActiveCell.Value = ((Gagnés * 3) + Nuls) / NbJoués
Range("N" & Joueurs + 20).Select
ActiveCell.Value = ButsPour / NbJoués
Range("P" & Joueurs + 20).Select
ActiveCell.Value = ButsContre / NbJoués
Else
Range("L" & Joueurs + 20).Select
ActiveCell.Value = ""
Range("N" & Joueurs + 20).Select
ActiveCell.Value = ""
Range("P" & Joueurs + 20).Select
ActiveCell.Value = ""
End If
Next Joueurs
Range("B21:Q37").Select
If Application.Version = "9.0" Then
Selection.Sort Key1:=Range("D21"), Order1:=xlDescending, Key2:=Range( _
"K21"), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom
Else
Selection.Sort Key1:=Range("D21"), Order1:=xlDescending, Key2:=Range( _
"K21"), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
End If
Range("A21:Q28").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Range("A29:Q37").Select
With Selection.Interior
.ColorIndex = 0
.Pattern = xlSolid
End With
'Puis on s'arrange pour les refusionner
For Colonne = 12 To 16 Step 2
For Ligne = 21 To 37
Range(Chr(65 + Colonne - 1) & Ligne & ":" & Chr(65 + Colonne) & Ligne).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Next Ligne
Next Colonne
Range("A19").Select
End Sub
Cordialement.