Partendo dal file pubblicato ho sviluppato una Sub Avulsa, che va richiamata dopo l'aggiornamento della Classifica e dei risultati.
Il suo codice:
- Codice: Seleziona tutto
Sub Avulsa()
Dim I As Long, LastC As Long, cTeam As String, cTPoints As Long, DR As String, sTeam As String
Dim GF As String, DRW As Double, RndW As Double, GFW As Double, J As Long, K As Long, Lb0 As Long, KK As Long
Dim Class As Worksheet, Calend As Worksheet, CArr, dgD As Long, PcT As Long, PsT As Long
'
'KK = True
'aaa = 1 * KK
Set Class = Sheets("CLASSIFICA")
Set Calend = Sheets("CALENDARIO")
DR = "K"
GF = "I"
DRW = 10000000
GFW = DRW * 1000
RndW = DRW * 1000
'
LastC = Class.Cells(Rows.Count, "C").End(xlUp).Row
lastb = Calend.Cells(Rows.Count, "B").End(xlUp).Row
CArr = Calend.Range("A1").Resize(lastb, 6).Value
Lb0 = LBound(CArr, 1)
Range("M1").Resize(lastb, 1).ClearContents
For I = 4 To LastC - 0
DoEvents
cTeam = Cells(I, 3)
Cells(I, "M").Value = Cells(I, "M").Value + Rnd() / RndW + Cells(I, GF) / GFW + Cells(I, DR) / DRW
Cells(I, 4).Value = Round(Cells(I, 4).Value, 0) + Cells(I, "M").Value '<><> Vedi testo
cTPoints = Round(Cells(I, 4).Value, 0)
If I < LastC Then
For J = I + 1 To LastC
If cTeam <> Cells(J, 3) Then
If Round(Cells(J, 4).Value, 0) = cTPoints Then
sTeam = Cells(J, 3)
dgD = 0: PcT = 0: PsT = 0: KK = 0
For K = Lb0 To UBound(CArr, 1)
DoEvents
If CArr(K, Lb0 + 2) = cTeam And CArr(K, Lb0 + 3) = sTeam Then KK = 1
If CArr(K, Lb0 + 2) = sTeam And CArr(K, Lb0 + 3) = cTeam Then KK = 2
If KK > 0 Then
Debug.Print K, CArr(K, Lb0 + 2), CArr(K, Lb0 + 3), CArr(K, Lb0 + 4)
Res = Split(Trim(CArr(K, Lb0 + 4)), "-", , vbTextCompare)
If UBound(Res) = 1 Then
If Res(0) = Res(1) Then
PcT = PcT + 1: PsT = PsT + 1
ElseIf Res(0) > Res(1) Then
If KK = 1 Then PcT = PcT + 3 Else PsT = PsT + 3
If KK = 1 Then dgD = dgD + CLng(Res(0)) Else dgD = dgD - CLng(Res(0))
Else
If KK = 2 Then PcT = PcT + 3 Else PsT = PsT + 3
If KK = 2 Then dgD = dgD + CLng(Res(0)) - CLng(Res(1)) Else dgD = dgD - CLng(Res(0)) + CLng(Res(1))
End If
End If
KK = 0
End If
Next K
Cells(I, "M").Value = Cells(I, "M").Value + PcT / 100 + dgD / 10000
Cells(I, 4).Value = Cells(I, 4).Value + PcT / 100 + dgD / 10000 '<><> Vedi testo
Cells(J, "M").Value = Cells(J, "M").Value + PsT / 100 - dgD / 10000
Cells(J, 4).Value = Cells(J, 4).Value + PsT / 100 - dgD / 10000 '<><> Vedi testo
End If
End If
Next J
End If
Next I
'MsgBox ("Completato...")
End Sub
Per automatizzare il tutto ho modificato quindi il codice associato al pulsante Aggiorna Classifica come segue:
- Codice: Seleziona tutto
Sub Classifica()
'
' Macro1 Macro
'
Sheets("CLASSIFICA").Select
DoEvents
Sheets("CALENDARIO").Range("C3").QueryTable.BackgroundQuery = False
Call Importa
DoEvents
Sheets("CLASSIFICA").Range("C3").QueryTable.BackgroundQuery = False
ActiveWorkbook.Connections("Connessione1").Refresh
DoEvents
Call Avulsa
Msgbox("Completato...")
End Sub
Questa in sequanza: aggiorna i risultati, aggiorna la classifica, aggiunge i punti della classifica avulsa.
La colonna D (Punti) sara' modificata come segue:
upload immaginiIn questo modo, ordinando la tabella in ordine di Punti (colonna D) le squadre saranno posizionate secondo i punto complessivi, compreso quelli ottenuti dalla procedura "avulsa".
La parte Intera arrotondata sono i punti iniziali
-I primi 2 decimali sono i punti negli scontri diretti (*)
-I secondi 2 decimali sono la differenza reti negli scontri diretti (*)
-I successivi 3 decimali sono la quote differenza reti complessiva (**)
-I successivi 3 decimali sono la quota reti fatte complessive (**)
-Gli ultimi 3 decimali sono un valore random
Nota*: questo contributo, nella figura, e' presente solo per le squadre Grottaferrata e Casilina, che avendo pari punteggio di partenza devono usare i punti avulsi per la classifica finale.
Nota**: questo contributo si nota soprattutto nel caso della Lupa e Garbatella; le altre squadre, avendo una differenza reti negativa, il loro funzionamento e' meno evidente.
Per non vedere i decimali prodotti dal calcolo della classifica avulsa, la colonna D (Punti) sara' visualizzata senza decimali.
I soli "punti avulsi" sono calcolati anche in colonna M.
Se non si vuole che anche la colonna D contenga questi punti allora, nel codice della Sub Avulsa vanno eliminate le istruzioni marcate <><>
Il foglio Avulse, con tutto il suo corredo di macro, non so e' ancora da mantenere.
Il file aggiornato e' disponibile qui:
https://www.dropbox.com/s/7iq6wmf8t5het ... 5.xls?dl=0Ciao