Questa macro rappresenta la mia interpretazione del problema; le scarne informazioni che hai fornito lasciano parecchi margini alla fantasia personale.
- Codice: Seleziona tutto
Private Sub Worksheet_Activate()
Dim myRes(1 To 5), myGara1 As String, myGara2 As String, I As Long, J As Long, myQualif As String
'
'>>> Informazioni
myGara1 = "C25:K38" '<<< Area dati Gara1, su ogni foglio Circuito
myGara2 = "C44:K58" '<<< Idem Gara2
myQualif = "C4:J18" '<<< Area qualifica
CPil = "B3:J17" '<<< Area Elenco piloti su Classifica
'
For Each karter In Range(CPil).Offset(0, 1).Resize(, 1)
For I = 2 To ThisWorkbook.Worksheets.Count
With Sheets(I)
'Gap
On Error Resume Next
'
myRes(1) = myRes(1) + wmsec(Application.WorksheetFunction.VLookup(karter.Value, .Range(myGara1), 6, 0))
myRes(1) = myRes(1) + wmsec(Application.WorksheetFunction.VLookup(karter.Value, .Range(myGara2), 6, 0))
'Starts
zzz = Application.WorksheetFunction.CountIf(.Range(myGara1), karter.Value)
myRes(2) = myRes(2) + Application.WorksheetFunction.CountIf(.Range(myGara1), karter.Value)
myRes(2) = myRes(2) + Application.WorksheetFunction.CountIf(.Range(myGara2), karter.Value)
'poles
myQT = Application.WorksheetFunction.VLookup(karter.Value, .Range(myQualif), 6, 0)
If wmsec(myQT) = 0 And Not IsEmpty(myQT) Then myRes(3) = myRes(3) + 1
'wins
myGT = Application.WorksheetFunction.VLookup(karter.Value, .Range(myGara1), 6, 0)
If wmsec(myGT) = 0 And Not IsEmpty(myGT) Then myRes(4) = myRes(4) + 1
myGT = Application.WorksheetFunction.VLookup(karter.Value, .Range(myGara2), 6, 0)
If wmsec(myGT) = 0 And Not IsEmpty(myGT) Then myRes(4) = myRes(4) + 1
'podium
If Application.WorksheetFunction.VLookup(karter.Value, .Range(myGara1), 8, 0) >= 18 Then myRes(5) = myRes(5) + 1
If Application.WorksheetFunction.VLookup(karter.Value, .Range(myGara2), 8, 0) >= 18 Then myRes(5) = myRes(5) + 1
End With
Next I
karter.Offset(0, 3).Resize(1, 5) = myRes()
karter.Offset(0, 3).Value = karter.Offset(0, 3).Value / 24 / 3600
myRes(1) = Empty: myRes(2) = Empty: myRes(3) = Empty: myRes(4) = Empty: myRes(5) = Empty
Next karter
'Call Macro1 '****Richiama una macro per Ordinare il foglio
End Sub
Function wmsec(ByVal fintimsm As String) As Double
Dim mSec As Integer, mySpl, mySpl2
fintimsm = Replace(fintimsm, "-", "0")
mySpl = Split(fintimsm, ".")
mySpl2 = Split(mySpl(LBound(mySpl)), ":")
wmsec = mySpl2(LBound(mySpl2)) * 60 + mySpl2(UBound(mySpl2)) + mySpl(UBound(mySpl)) / 1000
End Function
Tasto dx sul tab con nome fglio "Classifica", scegli Visualizza codice; copia il codice e incollalo nel frame di dx dell' editor delle macro che si e' aperto.
Personalizza le istruzioni marcate <<<, e sul foglio Classifica formatta le aree come da natura dei dati; in particolare F1:F17, dedicata al Gap sara' formattato come Categoria=Personalizzato e tipo=mm:ss,000
Per me infatti si tratta della somma dei vari "gap" contabilizzati su ogni circuito.
Tutte le volte che viene attivato il foglio Classifica, la macro ri-calcolera' i valori relativi a Classifica piloti.
Per la classifica a squadre, metti in E23 la formula
- Codice: Seleziona tutto
=MATR.SOMMA.PRODOTTO(--($D$3:$D$17=$C23);E$3:E$17)
Copia poi verso destra e copia la prima riga di formule verso il basso.
Per quanto riguarda l' ordinamento, registrati una macro mentre esegui su foglio Classifica gli ordinamenti che ti servono; poi inserisci in coda alla macro Worksheet_Activate un richiamo a questa macro; basta eliminare l' apostrofo in testa all' istruzione marcata *** e usare nella "Call" il nome reale della macro (che sostituira' "Macro1" nella riga)
Ribadisco che e' importante che ogni foglio "circuito" abbia lo stesso layout e le stesse posizioni; se il numero di atleti puo' variare nel corso del campionato devi quindi riservare le righe, nelle aree Qualifica, Gara1 e Gara2 idonee per accomodare tutti i nominativi che possono partecipare alle qualifiche e alle gare.
Ciao, fai sapere.