Classifica calcio

Hai un problema con Excel?

Nuova discussione
Classifica calcio
di Sdomf data: 01/11/2010
Salve a tutti l'altro giorno ho provato a creare un classifica che si autoaggiornasse.
ho trovato un tutorial che spiegava come farlo per 20 squadre, io modificandolo sono riuscito ad adattare la maggior parte del tutorial a 11 squadre (la quantita che mi serve).
ora devo però modificare l'ultimo codice vba, quello per l'aggiornamento delle classifiche, che vi lascio allegato. chi mi può aiutare?
(per vedere il tutorial cercate su google: classifiche con excel 2007 e cliccate sul secondo risultato)
Dim Squadre(1 To 20) As String
Dim Punti(1 To 20) As Integer
Dim Giocate(1 To 20) As Integer
Dim Vinte(1 To 20) As Integer
Dim Pareggiate(1 To 20) As Integer
Dim Perse(1 To 20) As Integer
Dim RetiFatte(1 To 20) As Integer
Dim RetiSubite(1 To 20) As Integer
Dim GoalsOspitanteAndata As Integer
Dim GoalsOspitataAndata As Integer
Dim GoalsOspitanteRitorno As Integer
Dim GoalsOspistataRitorno As Integer
Dim IDOspitante As Integer
Dim IDOspitata As Integer
Dim currentDate As Date

Sub Macro1()
'
' Macro1 Macro
' Macro registrata il 09/02/2007 da Maurizio
'
' Scelta rapida da tastiera: CTRL+MAIUSC+P
'


Dim J As Integer
Dim strDt As String
Dim Riga As Integer
Dim Andata As Boolean


 Sheets("Calendario").Select
 
 strDt = CStr(Cells(ActiveCell.Row, ActiveCell.Column))
 currentDate = CDate(strDt)
 If IsDate(strDt) = False Then
    MsgBox "Posizionare il cursore sulla data!"
    Exit Sub
 End If

'For J = 1 To 20
' Squadre(J) = Sheets("Squadre").Cells(J + 1, 1)
'Next

For J = 1 To 20
  Punti(J) = 0
  Giocate(J) = 0
  Vinte(J) = 0
  Pareggiate(J) = 0
  Perse(J) = 0
  RetiFatte(J) = 0
  RetiSubite(J) = 0
Next

Riga = ActiveCell.Row + 1

 If ActiveCell.Row = 1 Then
       MsgBox "Selezionare una riga valida!", vbCritical
 Else

Do While Riga < ActiveCell.Row + 11
   
 ' se la data è in colonna 2 si tratta dell'ANDATA
 ' altrimenti del RITORNO !
 If ActiveCell.Column = 2 Then
      ' ANDATA
      Andata = True
  
          If (IsEmpty(Cells(Riga, 1)) = False And IsEmpty(Cells(Riga, 2)) = False) Then
                GoalsOspitanteAndata = Cells(Riga, 1)
                GoalsOspitataAndata = Cells(Riga, 2)
                IDOspitante = Cells(Riga, 3)
                IDOspitata = Cells(Riga, 4)
                GoSub AggiornaAndata
          End If
Else
  ' RITORNO
  
    Andata = False
    
    If (IsEmpty(Cells(Riga, 5)) = False And IsEmpty(Cells(Riga, 6)) = False) Then
         GoalsOspitanteRitorno = Cells(Riga, 5)
         GoalsOspitataRitorno = Cells(Riga, 6)
         
        
        IDOspitante = Cells(Riga, 3)
        IDOspitata = Cells(Riga, 4)
        
        GoSub AggiornaRitorno
        
        
   End If
End If
   Riga = Riga + 1
 Loop
   
   
   
   Call AggiornaClassifica
   Sheets("Calendario").Select
   If Andata Then
        ActiveSheet.Cells(Riga + 1, 2).Select
   Else
        ActiveSheet.Cells(Riga + 1, 6).Select
   End If
   
   MsgBox "La classifica alla data del: " & strDt & " è stata aggiornata!", vbInformation
  
  
End If

Exit Sub

AggiornaAndata:

    Giocate(IDOspitante) = Giocate(IDOspitante) + 1
    Giocate(IDOspitata) = Giocate(IDOspitata) + 1
    
    RetiFatte(IDOspitante) = RetiFatte(IDOspitante) + GoalsOspitanteAndata
    RetiSubite(IDOspitata) = RetiSubite(IDOspitata) + GoalsOspitanteAndata
            
    RetiFatte(IDOspitata) = RetiFatte(IDOspitata) + GoalsOspitataAndata
    RetiSubite(IDOspitante) = RetiSubite(IDOspitante) + GoalsOspitataAndata
            
    If GoalsOspitanteAndata > GoalsOspitataAndata Then
       Punti(IDOspitante) = Punti(IDOspitante) + 3
       Punti(IDOspitata) = Punti(IDOspitata) + 0
       
       Vinte(IDOspitante) = Vinte(IDOspitante) + 1
       Perse(IDOspitata) = Perse(IDOspitata) + 1
       
    ElseIf GoalsOspitanteAndata < GoalsOspitataAndata Then
        Punti(IDOspitante) = Punti(IDOspitante) + 0
        Punti(IDOspitata) = Punti(IDOspitata) + 3
       
        Perse(IDOspitante) = Perse(IDOspitante) + 1
        Vinte(IDOspitata) = Vinte(IDOspitata) + 1
    Else
      ' pareggio
       Punti(IDOspitante) = Punti(IDOspitante) + 1
       Punti(IDOspitata) = Punti(IDOspitata) + 1
       
       Pareggiate(IDOspitante) = Pareggiate(IDOspitante) + 1
       Pareggiate(IDOspitata) = Pareggiate(IDOspitata) + 1
    End If

Return

AggiornaRitorno:

         Giocate(IDOspitante) = Giocate(IDOspitante) + 1
         Giocate(IDOspitata) = Giocate(IDOspitata) + 1
         
         RetiFatte(IDOspitante) = RetiFatte(IDOspitante) + GoalsOspitanteRitorno
         RetiSubite(IDOspitata) = RetiSubite(IDOspitata) + GoalsOspitanteRitorno
            
        RetiFatte(IDOspitata) = RetiFatte(IDOspitata) + GoalsOspitataRitorno
        RetiSubite(IDOspitante) = RetiSubite(IDOspitante) + GoalsOspitataRitorno
        
        If GoalsOspitanteRitorno > GoalsOspitataRitorno Then
           Punti(IDOspitante) = Punti(IDOspitante) + 3
           Punti(IDOspitata) = Punti(IDOspitata) + 0
           
           Vinte(IDOspitante) = Vinte(IDOspitante) + 1
           Perse(IDOspitata) = Perse(IDOspitata) + 1
       
        ElseIf GoalsOspitanteRitorno < GoalsOspitataRitorno Then
            Punti(IDOspitante) = Punti(IDOspitante) + 0
            Punti(IDOspitata) = Punti(IDOspitata) + 3
            
            Perse(IDOspitante) = Perse(IDOspitante) + 1
            Vinte(IDOspitata) = Vinte(IDOspitata) + 1
        
        Else
          ' pareggio
           Punti(IDOspitante) = Punti(IDOspitante) + 1
           Punti(IDOspitata) = Punti(IDOspitata) + 1
           
           Pareggiate(IDOspitante) = Pareggiate(IDOspitante) + 1
           Pareggiate(IDOspitata) = Pareggiate(IDOspitata) + 1
           
        End If
Return

End Sub


Private Sub AggiornaClassifica()

 Sheets("Squadre").Select

 For J = 2 To 21
  Cells(J, 2) = Cells(J, 2) + Punti(J - 1)
  Cells(J, 3) = Cells(J, 3) + Giocate(J - 1)
  Cells(J, 4) = Cells(J, 4) + Vinte(J - 1)
  Cells(J, 5) = Cells(J, 5) + Pareggiate(J - 1)
  Cells(J, 6) = Cells(J, 6) + Perse(J - 1)
  Cells(J, 7) = Cells(J, 7) + RetiFatte(J - 1)
  Cells(J, 8) = Cells(J, 8) + RetiSubite(J - 1)
  
 Next

 ActiveSheet.Cells(1, 1) = Format(currentDate, "MM-DD-YYYY")
 ' ORA OCCORRE METTERE IN ORDINE LE SQUADRE PER PUNTI DESCRESCENTE E
 ' TENERE CONTO DEI PUNTI DI PENALIZZAZIONE (COLONNA 9)
 
    Sheets("Squadre").Select
    currentDate = Cells(1, 1)
    Range("A2:I21").Select
    Selection.Copy
    Sheets("Classifica").Select
    Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Cells(1, 1) = currentDate
    For J = 2 To 21
      Cells(J, 2) = Cells(J, 2) + Cells(J, 9)
    Next
    Range("A2:I21").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
End Sub


Public Sub InserisciCasellaCombinata()
 '
 Dim J As Integer
 Dim X As Single
 Dim Y As Single
 Dim W As Single
 Dim H As Single
 
 Dim R As Integer
 Dim C As Integer
 
 Const sFillRange = "Squadre!$A$2:$A$21"
 
 R = ActiveCell.Row     ' R = Riga corrente
 C = ActiveCell.Column  ' C = Cella corrente
 
 ActiveSheet.Cells(R, C).Select   ' cella corrente selezionata (è superfluo!)

'ascissa: somma la larghezza di tutte le celle a sinistra della cella corrente
 
 X = 0
 For J = 1 To C - 1
   X = X + Cells(R, J).Width
 Next
 

' ordinata: somma tutte le altezze delle celle sopra quella corrente
Y = 0
For J = 1 To R - 1
  Y = Y + Cells(J, C).Height
Next


W = ActiveCell.Width   ' W = Larghezza della cella corrente
H = ActiveCell.Height  ' H = Altezza della cella corrente


' questa istruzione crea la casella combinata con le dimensioni volute!
' e la seleziona

ActiveSheet.DropDowns.Add(X, Y, W, H).Select
  
With Selection
        .ListFillRange = sFillRange       ' imposta origine dati a elenco squadre
        .LinkedCell = ActiveCell.Address  ' imposta coordinate cella sottostante
        .DropDownLines = 8                ' numero righe in elenco, modificabile!
        .Display3DShading = False         ' ombreggiatura 3d non serve!
End With
' FATTO!

End Sub


Sub Inserisci20CaselleCombinate()

 Dim J As Integer
  
 Dim R As Integer
 Dim C As Integer
 
 Dim FirstRow As Integer
 
 ' scopo: inserire 20 casella combinate sotto per 10 posizioni e a destra per 10 rispetto alla cella corrente
 
 R = ActiveCell.Row
 FirstRow = R
 C = ActiveCell.Column
 
 ' colonna di sinistra = 10  controlli da generare
  
 For J = R To R + 10
   ActiveSheet.Cells(J, C).Select
   Call InserisciCasellaCombinata
 Next

 ' colonna di destra = 10 controlli da generare
 C = C + 1                                  ' si sposta a destra di una colonna
 ActiveSheet.Cells(FirstRow, C).Select      ' seleziona la prima cella
 
 R = FirstRow
  
  For J = R To R + 10
   ActiveSheet.Cells(J, C).Select
   Call InserisciCasellaCombinata
 Next
 
 'FATTO!
 
End Sub
Vuoi Approfondire?