Il file ultimo allegato "include contenuto illegibile", quindi faccio ancora riferimento al file xls pubblicato il 27 mattina.
Ho modificato la Function FullPoints a cui ti avevo indirizzato per adattarla al nuovo layout dati e al calcolo dei punteggi; diventa pertanto:
- Codice: Seleziona tutto
Function FullPoints2(ByRef myTeams As Range, ByRef myCalend As Range) As Variant
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=104795 (base)
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=105492 (questa vers)
'
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
sHm = 4: sAw = 6: tHm = 0: tAw = 7 'mappa di tabella Calendario e risultati; s=Score, t=Team
'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) + 3
If wArr(J, LB2 + sHm) = wArr(J, LB2 + sAw) Then M1(I) = M1(I) + 1
M1(I) = M1(I) + (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 1000000
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) + 3
If wArr(J, LB2 + sHm) = wArr(J, LB2 + sAw) Then M1(I) = M1(I) + 1
M1(I) = M1(I) - (wArr(J, LB2 + sHm) - wArr(J, LB2 + sAw)) / 1000000
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
'
FullPoints2 = Application.WorksheetFunction.Transpose(M1)
DoEvents
End Function
Inseriscila nel tuo elenco macro: partendo da excel premi Alt-F11 per aprire l' editor delle macro; Menu /Inserisci /Modulo; copia il codice e incollalo nel frame di dx.
Poi vai sulle tabelle "Classifica Girone", ad esempio per quella in B48:N54 vai in N49 e usi la formula
- Codice: Seleziona tutto
=INDICE(FullPoints2($B$49:$B$54;$C$29:$J$43);RIF.RIGA(A1))
Poi copi la formula verso il basso per le altre squadre (vedi Nota*)
$B$49:$B$54 e' l'elenco squadre, $C$29:$J$43 e' la tabella dei risultati, RIF.RIGA(A1) serve per estrarre il dato della prima squadra; copiando verso il basso i riferimenti verranno automaticamente adeguati.
Nota*: si puo' anche usare la notazione "a matrice" per ottenere tutti i risultati:
Selezioni l'area N49:N54 e inserisci la formula
- Codice: Seleziona tutto
=FullPoints2($B$49:$B$54;$C$29:$J$43)
da confermare pero' con Contr-Maiusc-Enter
Il campo "Punteggio" va formattato come Numero con 0 decimali. Il Rango invece terra' conto anche dei decimali.
Non so cosa devi fare sul file dopo il calcolo dei punteggi, ma se usi il valore di questi punteggi in altre formule successive, allora dovrai usare ARROTONDA(IlPunteggio;0) invece del solo IlPunteggio.
Non so quale e' la compatibilita' tra quanto ti ho proposto e OpenOffice, se usi OpnOffice.
Ciao
