Anche in questo caso meglio ricorrere a una userfunction, che possa calcolare il punteggio integrandolo con gli elementi che servono.
Il codice della userfunction:
- Codice: Seleziona tutto
Function FullPoints(ByRef myTeams As Range, ByRef myCalend As Range) As Variant
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=104795
Dim M1() As Double, M2(), M3(), M4(), wArr, RCal As Range
Dim HMTms As Long, HMCals As Long, I As Long, J As Long, LB2 As Integer, K As Long
Dim sHm As Integer, sAw As Integer, tHm As Integer, tAw As Integer
HMTms = myTeams.Rows.Count
HMCals = myCalend.Rows.Count
'
Set RCal = Application.Intersect(myCalend, myCalend.Parent.UsedRange)
'
'Debug.Print Timer
'
ReDim M1(1 To HMTms)
wArr = RCal.Value
sHm = 0: sAw = 1: tHm = 2: tAw = 4 'mappa di tabella Calendario e risultati
'calcolo punti per vittoria e delta punti generale (/100000000)
LB2 = LBound(wArr, 2)
For I = 1 To HMTms
For J = LBound(wArr, 1) To UBound(wArr, 1)
If wArr(J, LB2 + tHm) = myTeams.Cells(I, 1).Value Then
If wArr(J, LB2 + sHm) > wArr(J, LB2 + sAw) Then M1(I) = M1(I) + 2
M1(I) = M1(I) + (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 100000000
End If
If wArr(J, LB2 + tAw) = myTeams.Cells(I, 1).Value Then
If wArr(J, LB2 + sHm) < wArr(J, LB2 + sAw) Then M1(I) = M1(I) + 2
M1(I) = M1(I) - (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 100000000
End If
Next J
Next I
'aggiungi VITTORIE (/100) e delta punti (/10000) in scontri diretti
For I = 1 To HMTms - 1
For K = I + 1 To HMTms
If Round(M1(I), 0) = Round(M1(K), 0) Then
For J = LBound(wArr, 1) To UBound(wArr, 1)
'Debug.Print I & " > " & K & " > " & J
If wArr(J, LB2 + tHm) = myTeams.Cells(I, 1).Value And wArr(J, LB2 + tAw) = myTeams.Cells(K, 1).Value Then
'(a) Delta punti dirette
M1(I) = M1(I) + (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 10000
M1(K) = M1(K) - (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 10000
'(b) Vittorie dirette
If wArr(J, LB2 + sHm) > wArr(J, LB2 + sAw) Then
M1(I) = M1(I) + 0.01
Else
M1(K) = M1(K) + 0.01
End If
End If
If wArr(J, LB2 + tHm) = myTeams.Cells(K, 1).Value And wArr(J, LB2 + tAw) = myTeams.Cells(I, 1).Value Then
'(a)
M1(I) = M1(I) - (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 10000
M1(K) = M1(K) + (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 10000
'(b)
If wArr(J, LB2 + sHm) > wArr(J, LB2 + sAw) Then
M1(K) = M1(K) + 0.01
Else
M1(I) = M1(I) + 0.01
End If
End If
Next J
End If
Next K
Next I
'
FullPoints = Application.WorksheetFunction.Transpose(M1)
DoEvents
End Function
Poi in C4 del primo foglio calcoli il punteggio della squadra con la formula
- Codice: Seleziona tutto
=INDICE(FullPoints($B$4:$B$9;Calendario!$I:$M);RIF.RIGA(A1))
Poi copi la formula verso il basso.
Nella formula, $B$4:$B$9 e' l' elenco delle squadre da valutare e Calendario!$I:$M) e' il riferimento alle colonne in cui si trovano risultati e squadre (la parte elaborata con le tue formule).
Il questo modo il punteggio sara' calcolato secondo le vittorie totali, piu' un fattore per gli scontri tra i pari punto, piu' un fattore piu' basso del delta punti sugli scontri tra i pari punto, piu' un fattore piu' basso per il delta pnti generale.
Dopo che hai collaudato il comportamento di quanto descritto, per non vedere i decimali formatterai le celle eliminando i decimali.
Riguardando le formule in Calendario non capisco le formule in colonna J e colonna M; io in J2 inserirei
- Codice: Seleziona tutto
=SOSTITUISCI(G2;I2&"-";"")
da copiare poi verso il basso
E in M2 analogamente
- Codice: Seleziona tutto
=SOSTITUISCI(A2;K2&"-";"")
Ciao
Registrazione
