Utilizzando il programma Lotto1-5 mi sono accorto che non avevo aggiornato la macro Ritardi, perché tenesse conto che le estrazioni ora partivano dal 1871. Questo comporta errori sui ritardi massimi, con valori senza senso:
Ora ho sistemato e dopo altri controlli posterò il tutto.
Per chi volesse, anche senza sapere come si fa, inserire la macro aggiornata, al posto di quella non corretta, sarei felice di spiegarle la procedura, lunga da spiegare, ma nei fatti una vera cag..., Vi potrebbe essere utile sapere come si fa per semplici correzioni, nel caso il pulsante, per un motivo qualsiasi, perdesse il collegamento alla macro.
Però prima di scrivere la procedura vorrei sapere se a qualcuno interessa, altrimenti sarebbe lavoro sprecato.
Faciteme saperi
Questa è corretta. E questa è la macro che la genera, non spaventatevi è un po lunga.
Come dici? Guardandola non ci capisci niente? Neanche io, però funziona
---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Option Explicit
Public Type AnalisiAvanzata
nomeRuota As String
indiceProbabilita As Double
tendenzaUltimi3Mesi As Double
regolaritaUscite As Double
ciclicita As Double
End Type
' ================================================================
' FUNZIONE: ParseDataItaliana
' (se già presente altrove nel modulo, rimuovila da qui)
' ================================================================
Private Function ParseDataItaliana(txt As String) As Date
Dim p() As String
txt = Trim(txt)
If txt = "" Then Exit Function
p = Split(txt, "/")
On Error GoTo fallback
If UBound(p) = 1 Then
ParseDataItaliana = DateSerial(Year(Date), CLng(p(1)), CLng(p(0)))
ElseIf UBound(p) = 2 Then
ParseDataItaliana = DateSerial(CLng(p(2)), CLng(p(1)), CLng(p(0)))
End If
Exit Function
fallback:
ParseDataItaliana = 0
End Function
' ================================================================
' HELPER: colonne ruota
' ================================================================
Private Sub GetColonneRuota(nomeRuota As String, ByRef colStart As Integer, ByRef colEnd As Integer)
Select Case Trim(UCase(nomeRuota))
Case "BARI": colStart = 4: colEnd = 8
Case "CAGLIARI": colStart = 9: colEnd = 13
Case "FIRENZE": colStart = 14: colEnd = 18
Case "GENOVA": colStart = 19: colEnd = 23
Case "MILANO": colStart = 24: colEnd = 28
Case "NAPOLI": colStart = 29: colEnd = 33
Case "PALERMO": colStart = 34: colEnd = 38
Case "ROMA": colStart = 39: colEnd = 43
Case "TORINO": colStart = 44: colEnd = 48
Case "VENEZIA": colStart = 49: colEnd = 53
Case "NAZIONALE": colStart = 54: colEnd = 58
End Select
End Sub
' ================================================================
' HELPER: indica se una ruota ha effettivamente estratto in una
' determinata riga (almeno un numero valido 1-90 tra le sue 5
' colonne). Usata per escludere dall'analisi le date in cui la
' ruota non ha estratto, per qualunque motivo: non ancora
' istituita, sospesa temporaneamente, interrotta, ecc.
' Molto più robusto del semplice "riga di inizio", perché copre
' anche interruzioni storiche nel mezzo della serie e non solo
' l'anno di istituzione.
' ================================================================
Private Function RuotaAttivaSuRiga(dati As Variant, riga As Long, colStart As Integer, colEnd As Integer) As Boolean
Dim col As Integer
Dim v As Variant
For col = colStart To colEnd
v = dati(riga, col)
If Not IsEmpty(v) Then
If IsNumeric(v) Then
If CLng(v) >= 1 And CLng(v) <= 90 Then
RuotaAttivaSuRiga = True
Exit Function
End If
End If
End If
Next col
RuotaAttivaSuRiga = False
End Function
' ================================================================
' SUB PRINCIPALE: AnalisiRitardi
' ================================================================
Sub AnalisiRitardiOld()
' -------------------------------------------------------
' SCELTA GIORNO (identica a CicliGruppo10)
' -------------------------------------------------------
Dim sceltaGiorno As String
Dim giornoTarget As Long
sceltaGiorno = InputBox("Quale giorno vuoi elaborare?" & vbCrLf & _
"martedi, giovedi, venerdi, sabato, tutti", _
"Seleziona giorno")
If sceltaGiorno = "" Then Exit Sub
sceltaGiorno = LCase(Trim(sceltaGiorno))
Select Case sceltaGiorno
Case "martedi", "martedì": giornoTarget = 3
Case "giovedi", "giovedì": giornoTarget = 5
Case "venerdi", "venerdì": giornoTarget = 6
Case "sabato": giornoTarget = 7
Case "tutti", "": giornoTarget = 0
Case Else
MsgBox "Giorno non valido. Inserire: martedi, giovedi, venerdi, sabato, tutti.", vbExclamation
Exit Sub
End Select
Dim infoGiorno As String
Select Case giornoTarget
Case 0: infoGiorno = "tutti i giorni"
Case 3: infoGiorno = "martedì"
Case 5: infoGiorno = "giovedì"
Case 6: infoGiorno = "venerdì"
Case 7: infoGiorno = "sabato"
End Select
' -------------------------------------------------------
Dim ws As Worksheet
Dim wsRisultati As Worksheet
Dim wsNumElab As Worksheet
Dim ruoteInput As String
Dim ruote() As String
Dim numeriDaAnalizzare As String
Dim Numeri() As String
Dim i As Integer, j As Long, r As Integer, col As Integer, pos As Integer
Dim ultimaRiga As Long
Dim RitardoAttuale As Long
Dim RitardoMassimo As Long
Dim frequenza As Long
Dim totaleEstrazioni As Long
Dim rigaInizio As Long
Dim ultimaUscita As String
Dim distanzaMedia As Double
Dim estrazioniConNumero() As Long
Dim estrCount As Long
Dim colonnaInizio As Integer
Dim colonnaFine As Integer
Dim rigaInizioRuota As Integer
Dim numero As Integer
Dim ultimaData As String
Dim ultimaRuota As String
Dim posizioniFreq(1 To 5) As Long
Dim RitardoPosizione(1 To 5) As Long
Dim posTrovata(1 To 5) As Boolean
Dim cellValue As Variant
Dim ritardoCorrente As Long
Dim sommaDistanze As Long
Dim maxPos As Long
Dim posizionePiuFreq As Integer
Dim totNumeri As Integer
Dim percAvanz As Integer
Dim numRuota As Integer
Dim ruoteNomiStr As String
Dim ruoteAbbrStr As String
Dim ultimaEstrazioneTrovata As Long
Dim trovatoRiga As Boolean
Dim rowData(1 To 14) As Variant
Dim ruotaAttiva() As Boolean
Dim almenoUnaAttivaRiga() As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo Cleanup
On Error Resume Next
Set wsNumElab = ThisWorkbook.Sheets("NumElab")
If Not wsNumElab Is Nothing Then
wsNumElab.UsedRange.ClearContents
End If
On Error GoTo Cleanup
Set ws = ThisWorkbook.Sheets("ArchivioFiltrato")
rigaInizio = 9
' --- Scelta ruote ---
ruoteInput = InputBox("Scegli le ruote per numero:" & vbCrLf & _
"1=BARI 2=CAGLIARI 3=FIRENZE 4=GENOVA 5=MILANO" & vbCrLf & _
"6=NAPOLI 7=PALERMO 8=ROMA 9=TORINO 10=VENEZIA 11=NAZIONALE" & vbCrLf & vbCrLf & _
"Inserisci i numeri separati da virgola (es: 1,3,8)" & vbCrLf & _
"Oppure scrivi 'TUTTE' per le ruote 1-10 (esclusa Nazionale)", "Selezione Ruote")
If ruoteInput = "" Then GoTo Cleanup
Dim RuoteNomi(1 To 11) As String
RuoteNomi(1) = "BARI": RuoteNomi(2) = "CAGLIARI": RuoteNomi(3) = "FIRENZE"
RuoteNomi(4) = "GENOVA": RuoteNomi(5) = "MILANO": RuoteNomi(6) = "NAPOLI"
RuoteNomi(7) = "PALERMO": RuoteNomi(8) = "ROMA": RuoteNomi(9) = "TORINO"
RuoteNomi(10) = "VENEZIA": RuoteNomi(11) = "NAZIONALE"
Dim ruoteAbbrevi(1 To 11) As String
ruoteAbbrevi(1) = "Ba": ruoteAbbrevi(2) = "Ca": ruoteAbbrevi(3) = "Fi"
ruoteAbbrevi(4) = "Ge": ruoteAbbrevi(5) = "Mi": ruoteAbbrevi(6) = "Na"
ruoteAbbrevi(7) = "Pa": ruoteAbbrevi(8) = "Ro": ruoteAbbrevi(9) = "To"
ruoteAbbrevi(10) = "Ve": ruoteAbbrevi(11) = "Naz"
If UCase(Trim(ruoteInput)) = "TUTTE" Then ruoteInput = "1,2,3,4,5,6,7,8,9,10"
Dim ruoteNumeri() As String
ruoteNumeri = Split(ruoteInput, ",")
ruoteNomiStr = ""
ruoteAbbrStr = ""
For i = 0 To UBound(ruoteNumeri)
numRuota = val(Trim(ruoteNumeri(i)))
If numRuota < 1 Or numRuota > 11 Then
MsgBox "Numero ruota non valido: " & Trim(ruoteNumeri(i)) & vbCrLf & _
"Inserire numeri da 1 a 11", vbExclamation
GoTo Cleanup
End If
If ruoteNomiStr = "" Then
ruoteNomiStr = RuoteNomi(numRuota)
ruoteAbbrStr = ruoteAbbrevi(numRuota)
Else
ruoteNomiStr = ruoteNomiStr & "," & RuoteNomi(numRuota)
ruoteAbbrStr = ruoteAbbrStr & ", " & ruoteAbbrevi(numRuota)
End If
Next i
ruote = Split(ruoteNomiStr, ",")
' --- Scelta numeri ---
numeriDaAnalizzare = InputBox("Inserisci i numeri separati da virgola (es: 1,4,7,90)" & vbCrLf & _
"Oppure scrivi 'TUTTI' per analizzare tutti i 90 numeri:", "Inserimento Numeri")
If numeriDaAnalizzare = "" Then GoTo Cleanup
If UCase(Trim(numeriDaAnalizzare)) = "TUTTI" Then
ReDim Numeri(89)
For i = 0 To 89
Numeri(i) = CStr(i + 1)
Next i
Else
Numeri = Split(numeriDaAnalizzare, ",")
For i = 0 To UBound(Numeri)
If val(Trim(Numeri(i))) < 1 Or val(Trim(Numeri(i))) > 90 Then
MsgBox "Numero non valido: " & Trim(Numeri(i)) & ". Deve essere tra 1 e 90", vbExclamation
GoTo Cleanup
End If
Next i
End If
totNumeri = UBound(Numeri) + 1
ultimaRiga = ws.Range("C" & ws.Rows.count).End(xlUp).Row
' --- Carica ArchivioFiltrato in memoria ---
Dim datiArchivioFiltrato As Variant
datiArchivioFiltrato = ws.Range("A" & rigaInizio & ":BF" & ultimaRiga).Value
Dim totalRighe As Long
totalRighe = UBound(datiArchivioFiltrato, 1)
' -------------------------------------------------------
' COSTRUZIONE MASCHERA RIGHE VALIDE PER GIORNO
' righeValide(j) = True se la riga j passa il filtro
' -------------------------------------------------------
Dim righeValide() As Boolean
ReDim righeValide(1 To totalRighe)
Dim contRigheValide As Long
contRigheValide = 0
Dim jj As Long
For jj = 1 To totalRighe
If giornoTarget = 0 Then
righeValide(jj) = True
contRigheValide = contRigheValide + 1
Else
Dim dvGiorno As Variant
dvGiorno = datiArchivioFiltrato(jj, 3) ' colonna C = offset 3 nell'array (A=1,B=2,C=3)
Dim dataGiorno As Date
If IsDate(dvGiorno) Then
dataGiorno = CDate(dvGiorno)
Else
dataGiorno = ParseDataItaliana(CStr(dvGiorno))
End If
If dataGiorno > 0 And Weekday(dataGiorno) = giornoTarget Then
righeValide(jj) = True
contRigheValide = contRigheValide + 1
Else
righeValide(jj) = False
End If
End If
Next jj
' -------------------------------------------------------
' -------------------------------------------------------
' PRECALCOLO: per ogni riga e per ogni ruota selezionata,
' la ruota ha davvero estratto quel giorno? Gestisce sia le
' ruote non ancora istituite sia eventuali sospensioni /
' interruzioni storiche nel mezzo della serie.
' -------------------------------------------------------
ReDim ruotaAttiva(1 To totalRighe, 0 To UBound(ruote))
ReDim almenoUnaAttivaRiga(1 To totalRighe)
For jj = 1 To totalRighe
Dim trovataAttiva As Boolean
trovataAttiva = False
For r = 0 To UBound(ruote)
Call GetColonneRuota(ruote(r), colonnaInizio, colonnaFine)
ruotaAttiva(jj, r) = RuotaAttivaSuRiga(datiArchivioFiltrato, jj, colonnaInizio, colonnaFine)
If ruotaAttiva(jj, r) Then trovataAttiva = True
Next r
almenoUnaAttivaRiga(jj) = trovataAttiva
Next jj
' -------------------------------------------------------
' --- totaleEstrazioni: conteggio solo su righe valide E in cui
' la ruota ha effettivamente estratto ---
totaleEstrazioni = 0
For r = 0 To UBound(ruote)
For jj = 1 To totalRighe
If righeValide(jj) And ruotaAttiva(jj, r) Then totaleEstrazioni = totaleEstrazioni + 1
Next jj
Next r
' --- Foglio Ritardi ---
On Error Resume Next
Set wsRisultati = ThisWorkbook.Sheets("Ritardi")
If wsRisultati Is Nothing Then
Set wsRisultati = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
wsRisultati.Name = "Ritardi"
End If
wsRisultati.UsedRange.ClearContents
On Error GoTo Cleanup
With wsRisultati
.Cells(1, 1) = "Ruote analizzate: " & ruoteAbbrStr & " | Giorno: " & infoGiorno
.Cells(3, 1) = "Numero"
.Cells(3, 2) = "Ritardo Attuale"
.Cells(3, 3) = "Ritardo Massimo"
.Cells(3, 4) = "Frequenza"
.Cells(3, 5) = "Frequenza %"
.Cells(3, 6) = "Ultima Uscita"
.Cells(3, 7) = "Distanza Media"
.Cells(3, 8) = "Ultima Ruota"
.Cells(3, 9) = "Pos. Più Frequente"
.Cells(3, 10) = "Ritardo Pos.1"
.Cells(3, 11) = "Ritardo Pos.2"
.Cells(3, 12) = "Ritardo Pos.3"
.Cells(3, 13) = "Ritardo Pos.4"
.Cells(3, 14) = "Ritardo Pos.5"
End With
Application.StatusBar = "Avvio analisi..."
' ================================================================
' LOOP NUMERI
' ================================================================
For i = 0 To UBound(Numeri)
numero = val(Trim(Numeri(i)))
percAvanz = Int(((i + 1) / totNumeri) * 100)
Application.StatusBar = "Analisi numero " & numero & _
" | " & (i + 1) & " di " & totNumeri & _
" | " & percAvanz & "% " & _
String(Int(percAvanz / 5), "|") & _
String(20 - Int(percAvanz / 5), ".")
RitardoAttuale = 0
RitardoMassimo = 0
frequenza = 0
ritardoCorrente = 0
ultimaEstrazioneTrovata = 0
ultimaData = ""
ultimaRuota = ""
estrCount = 0
ReDim estrazioniConNumero(0)
sommaDistanze = 0
For j = 1 To 5
posizioniFreq(j) = 0
posTrovata(j) = False
Next j
' --- contatore progressivo delle sole righe valide, a partire
' dalla prima riga in cui esiste almeno una ruota selezionata ---
Dim contValido As Long
contValido = 0
Dim ultimoContValido As Long
ultimoContValido = 0
For j = 1 To totalRighe
' Salta righe non valide per il giorno scelto
If Not righeValide(j) Then GoTo NextRigaNum
' Salta righe in cui NESSUNA delle ruote selezionate ha
' effettivamente estratto (non istituita, sospesa, ecc.)
If Not almenoUnaAttivaRiga(j) Then GoTo NextRigaNum
contValido = contValido + 1 ' indice progressivo sulle sole righe valide
For r = 0 To UBound(ruote)
' Salta la singola ruota se non ha estratto in questa riga
If Not ruotaAttiva(j, r) Then GoTo NextRuotaAnalisi
Call GetColonneRuota(ruote(r), colonnaInizio, colonnaFine)
For col = colonnaInizio To colonnaFine
cellValue = datiArchivioFiltrato(j, col)
If IsNumeric(cellValue) Then
If CLng(cellValue) = numero Then
frequenza = frequenza + 1
ultimaData = datiArchivioFiltrato(j, 3)
ultimaRuota = Trim(ruote(r))
posizioniFreq(col - colonnaInizio + 1) = posizioniFreq(col - colonnaInizio + 1) + 1
estrCount = estrCount + 1
ReDim Preserve estrazioniConNumero(estrCount)
estrazioniConNumero(estrCount) = contValido ' usa contatore valido
If ultimoContValido > 0 Then
ritardoCorrente = contValido - ultimoContValido
If ritardoCorrente > RitardoMassimo Then RitardoMassimo = ritardoCorrente
End If
ultimoContValido = contValido
ultimaEstrazioneTrovata = contValido
End If
End If
Next col
NextRuotaAnalisi:
Next r
NextRigaNum:
Next j
' Ritardo attuale (in estrazioni valide, dall'istituzione della ruota)
If ultimaEstrazioneTrovata > 0 Then
RitardoAttuale = contValido - ultimaEstrazioneTrovata
Else
RitardoAttuale = contValido
End If
' Ritardo massimo: considera ritardo iniziale (dall'istituzione
' della ruota, non dall'inizio assoluto dell'archivio) e ritardo attuale
If estrCount > 0 Then
Dim ritardoIniziale As Long
ritardoIniziale = estrazioniConNumero(1) - 1
If ritardoIniziale > RitardoMassimo Then RitardoMassimo = ritardoIniziale
If RitardoAttuale > RitardoMassimo Then RitardoMassimo = RitardoAttuale
End If
' Distanza media
distanzaMedia = 0
If estrCount > 1 Then
For j = 2 To estrCount
sommaDistanze = sommaDistanze + (estrazioniConNumero(j) - estrazioniConNumero(j - 1))
Next j
distanzaMedia = Round(sommaDistanze / (estrCount - 1), 2)
End If
' Posizione più frequente
maxPos = 0
For j = 1 To 5
If posizioniFreq(j) > maxPos Then
maxPos = posizioniFreq(j)
posizionePiuFreq = j
End If
Next j
' Ritardo per posizione (scansione al contrario, solo righe valide,
' fermandosi all'istituzione della prima ruota selezionata)
Dim ritPos(1 To 5) As Long
Dim trovPos(1 To 5) As Boolean
For pos = 1 To 5: ritPos(pos) = 0: trovPos(pos) = False: Next pos
For j = totalRighe To 1 Step -1
If Not righeValide(j) Then GoTo NextRigaPos
' Salta righe in cui nessuna ruota selezionata ha estratto
If Not almenoUnaAttivaRiga(j) Then GoTo NextRigaPos
Dim posTrov(1 To 5) As Boolean
For pos = 1 To 5: posTrov(pos) = False: Next pos
For r = 0 To UBound(ruote)
If Not ruotaAttiva(j, r) Then GoTo NextRuotaPos
Call GetColonneRuota(ruote(r), colonnaInizio, colonnaFine)
For col = colonnaInizio To colonnaFine
cellValue = datiArchivioFiltrato(j, col)
If IsNumeric(cellValue) Then
If CLng(cellValue) = numero Then
posTrov(col - colonnaInizio + 1) = True
End If
End If
Next col
NextRuotaPos:
Next r
For pos = 1 To 5
If posTrov(pos) Then
trovPos(pos) = True
ElseIf Not trovPos(pos) Then
ritPos(pos) = ritPos(pos) + 1
End If
Next pos
NextRigaPos:
Next j
' Scrittura riga
rowData(1) = numero
rowData(2) = RitardoAttuale
rowData(3) = RitardoMassimo - 1
rowData(4) = frequenza
rowData(5) = IIf(totaleEstrazioni > 0, frequenza / totaleEstrazioni, 0)
rowData(6) = ultimaData
rowData(7) = distanzaMedia
rowData(8) = ultimaRuota
rowData(9) = posizionePiuFreq
rowData(10) = ritPos(1)
rowData(11) = ritPos(2)
rowData(12) = ritPos(3)
rowData(13) = ritPos(4)
rowData(14) = ritPos(5)
wsRisultati.Cells(i + 4, 1).Resize(1, 14).Value = rowData
wsRisultati.Cells(i + 4, 5).NumberFormat = "0.00%"
Next i
' --- Formattazione foglio Ritardi ---
Application.StatusBar = "Formattazione risultati..."
With wsRisultati
.Cells(2, 1) = "Ultima estrazione analizzata: " & _
datiArchivioFiltrato(totalRighe, 3) & _
" | Giorno filtrato: " & infoGiorno
.Range("A1:A2").Font.Bold = True
.Range("A3:N3").Font.Bold = True
.Columns("B:N").AutoFit
.Columns("A").ColumnWidth = 12
.Range("A3:N" & (UBound(Numeri) + 4)).Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False
' --- Salvataggio PDF opzionale ---
If MsgBox("Analisi completata! Vuoi salvare i risultati in PDF?", vbQuestion + vbYesNo) = vbYes Then
Dim percorsoFile As Variant
Dim dataOra As String
dataOra = Format(Now, "yyyymmdd_hhnn")
percorsoFile = Application.GetSaveAsFilename( _
InitialFileName:=ThisWorkbook.Path & "\Analisi_Ritardi_" & dataOra & ".pdf", _
FileFilter:="File PDF (*.pdf), *.pdf", _
Title:="Salva PDF come")
If percorsoFile <> False Then
If LCase(right(percorsoFile, 4)) <> ".pdf" Then percorsoFile = percorsoFile & ".pdf"
With wsRisultati
.PageSetup.Orientation = xlPortrait
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = False
.PageSetup.LeftMargin = Application.InchesToPoints(0.5)
.PageSetup.RightMargin = Application.InchesToPoints(0.5)
.PageSetup.TopMargin = Application.InchesToPoints(0.5)
.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
.PageSetup.PrintArea = "$A$1:$N$" & (UBound(Numeri) + 4)
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=percorsoFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End With
MsgBox "PDF salvato come: " & percorsoFile, vbInformation
Else
MsgBox "Esportazione PDF annullata.", vbInformation
End If
End If
MsgBox "I risultati sono disponibili nel foglio 'Ritardi'." & vbCrLf & _
"Giorno elaborato: " & infoGiorno, vbInformation
' --- Analisi avanzata probabilità ---
Application.StatusBar = "Analisi avanzata probabilità..."
For i = 0 To UBound(Numeri)
numero = val(Trim(Numeri(i)))
If numero >= 1 And numero <= 90 Then
Application.StatusBar = "Analisi avanzata: numero " & numero & _
" (" & (i + 1) & " di " & totNumeri & ")"
Call AnalisiAvanzataProbabilita(numero, datiArchivioFiltrato, ruote, righeValide, _
ruotaAttiva, infoGiorno)
End If
Next i
Application.StatusBar = False
Exit Sub
Cleanup:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False
If Err.Number <> 0 Then MsgBox "Errore: " & Err.Description, vbCritical
End Sub
' ================================================================
' ANALISI AVANZATA PROBABILITÀ
' (aggiornata con filtro giorno E istituzione storica ruote)
' ================================================================
Private Sub AnalisiAvanzataProbabilita(numero As Integer, datiArchivioFiltrato As Variant, _
ruote() As String, righeValide() As Boolean, _
ruotaAttiva() As Boolean, infoGiorno As String)
Dim wsNumElab As Worksheet
On Error Resume Next
Set wsNumElab = ThisWorkbook.Sheets("NumElab")
On Error GoTo 0
If wsNumElab Is Nothing Then
Set wsNumElab = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
wsNumElab.Name = "NumElab"
End If
If Trim(wsNumElab.Cells(1, 1).Value) = "" Then
wsNumElab.Range("A1:J1").Value = Array("Numero", "Ruota", "Indice Probabilità", _
"Ritardo Attuale", "Ritardo Max", "Punto Z", _
"Ciclo Uscita", "Maturità %", "Score Totale", "Giorno")
End If
Dim ritardoAtt As Long, ritardoMax As Long, puntoZ As Double, distanzaMedia As Double
Dim wsRisultati As Worksheet
Set wsRisultati = ThisWorkbook.Sheets("Ritardi")
Dim rigaTrovata As Range
Set rigaTrovata = wsRisultati.Range("A:A").Find(What:=numero, LookIn:=xlValues, LookAt:=xlWhole)
If Not rigaTrovata Is Nothing Then
ritardoAtt = wsRisultati.Cells(rigaTrovata.Row, 2).Value
ritardoMax = wsRisultati.Cells(rigaTrovata.Row, 3).Value
distanzaMedia = wsRisultati.Cells(rigaTrovata.Row, 7).Value
Dim freqPerc As Double
freqPerc = wsRisultati.Cells(rigaTrovata.Row, 5).Value
If freqPerc > 0 Then puntoZ = 1 / freqPerc
End If
Dim lastRow As Long
lastRow = wsNumElab.Cells(wsNumElab.Rows.count, 1).End(xlUp).Row
If lastRow < 1 Then lastRow = 1
Dim analisi() As AnalisiAvanzata
ReDim analisi(UBound(ruote))
Dim dataUltimaEstrazione As Date
Dim totalRighe As Long
totalRighe = UBound(datiArchivioFiltrato, 1)
' Trova ultima riga valida per data
Dim jUlt As Long
For jUlt = totalRighe To 1 Step -1
If IsDate(datiArchivioFiltrato(jUlt, 3)) Then
dataUltimaEstrazione = CDate(datiArchivioFiltrato(jUlt, 3))
Exit For
End If
Next jUlt
Dim data3MesiFa As Date
data3MesiFa = DateAdd("m", -3, dataUltimaEstrazione)
Dim r As Integer, j As Long, col As Integer
Dim colonnaInizio As Integer, colonnaFine As Integer
Dim cellValue As Variant
Dim dataCorrente As Date
Dim uscite3Mesi As Long, usciteTotali As Long
Dim lastIndex As Long
Dim mediaInt As Double, devStd As Double, ii As Long
Dim patt As Double
For r = 0 To UBound(ruote)
analisi(r).nomeRuota = ruote(r)
uscite3Mesi = 0
usciteTotali = 0
lastIndex = 0
mediaInt = 0
devStd = 0
patt = 0
Dim intervalli() As Long
ReDim intervalli(0)
Call GetColonneRuota(ruote(r), colonnaInizio, colonnaFine)
Dim contV As Long: contV = 0
For j = 1 To totalRighe
' Applica filtro giorno
If Not righeValide(j) Then GoTo NextItAv
' Salta le righe in cui questa ruota non ha estratto
' (non istituita, sospesa, ecc.) PRIMA di incrementare contV,
' cosicché il conteggio consideri solo estrazioni reali
If Not ruotaAttiva(j, r) Then GoTo NextItAv
contV = contV + 1
On Error Resume Next
dataCorrente = CDate(datiArchivioFiltrato(j, 3))
On Error GoTo 0
For col = colonnaInizio To colonnaFine
cellValue = datiArchivioFiltrato(j, col)
If IsNumeric(cellValue) Then
If CLng(cellValue) = numero Then
usciteTotali = usciteTotali + 1
If dataCorrente >= data3MesiFa Then uscite3Mesi = uscite3Mesi + 1
If lastIndex > 0 Then
ReDim Preserve intervalli(UBound(intervalli) + 1)
intervalli(UBound(intervalli)) = contV - lastIndex
End If
lastIndex = contV
End If
End If
Next col
NextItAv:
Next j
With analisi(r)
.tendenzaUltimi3Mesi = (uscite3Mesi / 13) * 100 ' ~13 estr/mese per giorno singolo
If UBound(intervalli) > 0 Then
For ii = 1 To UBound(intervalli): mediaInt = mediaInt + intervalli(ii): Next ii
mediaInt = mediaInt / UBound(intervalli)
For ii = 1 To UBound(intervalli): devStd = devStd + (intervalli(ii) - mediaInt) ^ 2: Next ii
devStd = Sqr(devStd / UBound(intervalli))
If mediaInt > 0 Then .regolaritaUscite = 100 / (1 + (devStd / mediaInt))
End If
If UBound(intervalli) > 2 Then
For ii = 1 To UBound(intervalli) - 2
If Abs(intervalli(ii) - intervalli(ii + 2)) < mediaInt * 0.2 Then patt = patt + 1
Next ii
.ciclicita = (patt / (UBound(intervalli) - 2)) * 100
End If
.indiceProbabilita = (.tendenzaUltimi3Mesi * 0.4) + (.regolaritaUscite * 0.35) + (.ciclicita * 0.25)
End With
Next r
Call OrdinaAnalisiPerProbabilita(analisi)
Dim cicloUscita As Double, maturita As Double, scoreTotale As Double, fattoreCiclo As Double
For r = 0 To UBound(analisi)
With analisi(r)
cicloUscita = 0: maturita = 0
If distanzaMedia > 0 Then
cicloUscita = (ritardoAtt / distanzaMedia) * 100
maturita = IIf(cicloUscita > 100, cicloUscita - 100, 0)
End If
scoreTotale = (.indiceProbabilita * 0.5) + (.tendenzaUltimi3Mesi * 0.3)
fattoreCiclo = IIf(cicloUscita >= 100, 0.2, (cicloUscita / 100) * 0.2)
scoreTotale = scoreTotale * (1 + fattoreCiclo)
If scoreTotale > 100 Then scoreTotale = 100
wsNumElab.Cells(lastRow + r + 1, 1).Value = numero
wsNumElab.Cells(lastRow + r + 1, 2).Value = .nomeRuota
wsNumElab.Cells(lastRow + r + 1, 3).Value = Round(.indiceProbabilita, 2)
wsNumElab.Cells(lastRow + r + 1, 4).Value = ritardoAtt
wsNumElab.Cells(lastRow + r + 1, 5).Value = ritardoMax
wsNumElab.Cells(lastRow + r + 1, 6).Value = Round(puntoZ, 2)
wsNumElab.Cells(lastRow + r + 1, 7).Value = Round(cicloUscita, 2)
wsNumElab.Cells(lastRow + r + 1, 8).Value = Round(maturita, 2)
wsNumElab.Cells(lastRow + r + 1, 9).Value = Round(scoreTotale, 2)
wsNumElab.Cells(lastRow + r + 1, 10).Value = infoGiorno
End With
Next r
With wsNumElab
.Range("A1:J1").Font.Bold = True
.Columns("B:J").AutoFit
.Range("A1:J" & (lastRow + UBound(analisi) + 1)).Borders.LineStyle = xlContinuous
End With
End Sub
' ================================================================
' ORDINAMENTO (invariato)
' ================================================================
Private Sub OrdinaAnalisiPerProbabilita(analisi() As AnalisiAvanzata)
Dim i As Long, j As Long
Dim temp As AnalisiAvanzata
For i = LBound(analisi) To UBound(analisi) - 1
For j = i + 1 To UBound(analisi)
If analisi(j).indiceProbabilita > analisi(i).indiceProbabilita Then
temp = analisi(i): analisi(i) = analisi(j): analisi(j) = temp
End If
Next j
Next i
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
