lotto_tom75
Advanced Premium Member
Codice:
Option Explicit
Class clsCombinazione
Private aNum
Private aBNum
Private mFrequenze
Private mPresenze
Private mClasse
Private mKey
Private aIdEstr
Private nTrov
Private Sub Class_Initialize()
mFrequenze = 0
mPresenze = 0
ReDim aBnum(90)
End Sub
Public Property Get Classe
Classe = mClasse
End Property
Public Property Let Classe(v)
mClasse = v
End Property
Public Property Get ArrayNum
ArrayNum = aNum
End Property
Public Property Get Key
Key = mKey
End Property
Public Property Let Key(v)
mKey = v
End Property
Public Property Get Presenze
Presenze = mPresenze
End Property
Public Property Get Frequenze
Frequenze = mFrequenze
End Property
Public Property Get Combinazione
Combinazione = StringaNumeri(aNum,,True)
End Property
Sub IncrementaFrequenze
mFrequenze = mFrequenze + 1
End Sub
Sub SetNumeri(aNumTmp)
Dim k
aNum = aNumTmp
For k = 1 To UBound(aNum)
aBNum(aNum(k)) = True
Next
End Sub
Sub CalcolaFrequenza(aRuote,nSorte,nIni,nFin)
mFrequenze = SerieFreqTurbo(nIni,nFin,aNum,aRuote,nSorte)
End Sub
Sub CalcolaPresenze(aRuote,nSorte,Inizio,Fine)
Dim k,r,e,nPunti,aNumRuota,nPresenze
Dim aB
nPresenze = 0
For k = Inizio To Fine
For r = 1 To UBound(aRuote)
Call GetArrayNumeriRuota(k,aRuote(r),aNumRuota)
nPunti = 0
For e = 1 To 5
If aBNum(aNumRuota(e)) Then
nPunti = nPunti + 1
End If
Next
If nPunti >= nSorte Then
nPresenze = nPresenze + 1
End If
Next
Next
mPresenze = nPresenze
End Sub
Sub AddIdEstr(v)
nTrov = nTrov + 1
ReDim Preserve aIdEstr(nTrov)
aIdEstr(nTrov) = v
End Sub
End Class
Private aEstrattiBool
Sub Main
Dim nEstrDaUSare,nClasse,nSorte,CollLunghette,nIni,nFin,k
nEstrDaUSare = 18
nClasse = 3
nSorte = 1
' ReDim aRuote(10)
' For k = 1 To 10
' aRuote (k) = k
' Next
ReDim aRuote(1)
aRuote(1) = FI_
nIni =(EstrazioneFin - nEstrDaUSare) + 1
nFin = EstrazioneFin
Set CollLunghette = GetCollLunghettaMigliori(nIni,nFin,nClasse,nSorte,aRuote,nEstrDaUSare)
Call AlimentaTabOutput(CollLunghette,aRuote,nClasse,nSorte)
MsgBox TempoTrascorso
End Sub
Sub AlimentaTabOutput(CollLunghette,aRuote,nClasse,nSorte)
Dim av,cLung
Scrivi "Ruote : " & StringaRuote(aRuote)
Scrivi "Classe : " & nClasse
Scrivi "Sorte : " & nSorte
av = Array("","Lunghetta","Frequenza","Presenza")
Call InitTabella(av)
For Each cLung In CollLunghette
av(1) = cLung.Combinazione
av(2) = cLung.Frequenze
av(3) = cLung.Presenze
Call AddRigaTabella(av)
Next
Call CreaTabella
End Sub
Function GetCollLunghettaMigliori(Inizio,Fine,nClasse,nSorte,aRuote,nEstrUsate)
Dim CollComb,cComb
Dim CollLung,cLung
Dim k,j,e
Dim nFatte,nDaFare
Dim nRetFrequenze
Dim sKey
ReDim aCol(nSorte)
ReDim abNumValidi(90)
ReDim aEstrattiBool(nEstrUsate,12,90)
Call AlimentaArrayEstrattiBool(aEstrattiBool,Inizio,Fine,aRuote)
Set CollComb = GetNewCollection
Set CollLung = GetNewCollection
' alimento una collection con tutte le combinazioni di classe <nSorte> che si
' formano con le cinquine comprese nel range interessato
' di ogni singola combinazione si calcolano le frequenze
Dim quantitanumeriscelti
'ReDim aNum(0)
'quantitanumeriscelti = ScegliNumeri(aNum)
For k = Inizio To Fine
For j = 1 To UBound(aRuote)
ReDim aNum(0)
Call GetArrayNumeriRuota(k,aRuote(j),aNum)
For e = 1 To 5
abNumValidi(aNum(e)) = True
Next
Call OrdinaMatrice(aNum,1)
Call InitSviluppoIntegrale(aNum,nSorte)
Do While GetCombSviluppo(aCol)
sKey = "k" & StringaNumeri(aCol,,True)
If GetItemCollection(CollComb,sKey,cComb) Then
cComb.IncrementaFrequenze
Else
Set cComb = New clsCombinazione
cComb.Classe = nSorte
cComb.SetNumeri(aCol)
cComb.key = sKey
cComb.IncrementaFrequenze
Call AddItemColl(CollComb,cComb,sKey)
End If
Loop
Next
Call AvanzamentoElab(Inizio,Fine,k)
Next
Call AvanzamentoElab(Inizio,Fine,Inizio)
' ordino la collection contenente tutte le combinazioni di classe <nSorte> per il valore frequenza
Call OrdinaItemCollection(CollComb,"Frequenze","Key")
' da ognuna delle combinazioni base scasturirà una lunghetta quindi ciclo su tutte
' le combinazioni base presenti nella collection e per ciascuna costruirò una lunghetta
nDaFare = CollComb.count
nFatte = 0
For Each cComb In CollComb
ReDim aRetCol(nClasse)
' ottiene la lunghetta "migliore" che contiene la combinazione base
If GetLung(cComb,aRetCol,nRetFrequenze,CollComb,Inizio,Fine,aRuote,nSorte,nClasse,abNumValidi,nEstrUsate) Then
' aggiungo la lunghetta trovata in una nuova collection
Set cLung = New clsCombinazione
cLung.Classe = nClasse
Call OrdinaMatrice(aRetCol,1)
cLung.SetNumeri(aRetCol)
sKey = "k" & StringaNumeri(aRetCol,,True)
Call cLung.CalcolaFrequenza(aRuote,nSorte,Inizio,Fine)
Call cLung.CalcolaPresenze(aRuote,nSorte,Inizio,Fine)
Call AddItemInColl(cLung,sKey,CollLung)
End If
nFatte = nFatte + 1
If nFatte Mod 10 = 0 Then
Call AvanzamentoElab(1,nDaFare,nFatte)
If ScriptInterrotto Then Exit For
DoEventsEx
End If
Next
' ordino la collection delle lunghette trovate per poi mostrarle in output
Call OrdinaItemCollection(CollLung,"Presenze")
Set GetCollLunghettaMigliori = CollLung
End Function
Sub AlimentaArrayEstrattiBool(aEstrattiBool,Inizio,Fine,aRuote)
Dim idEstr,i,r,e
ReDim aNum(5)
For idEstr = Inizio To Fine
i = i + 1
For r = 1 To UBound(aRuote)
Call GetArrayNumeriRuota(idEstr,aRuote(r),aNum)
For e = 1 To 5
aEstrattiBool(i,aRuote(r),aNum(e)) = True
Next
Next
Next
End Sub
Sub AddItemInColl(cItem,sKey,Coll)
On Error Resume Next
Coll.Add cItem,sKey
If Err <> 0 Then Err.Clear
End Sub
Function GetLung(cComb,aRetCol,nRetPres,collComb,Inizio,Fine,aRuote,nSorte,nClasse,abNumValidi,nQtEstrUsate)
' a partire dalla combinazione base costruisce la lunghetta migliore (piu prolifica per presenze)
Dim nPos,n,nPresMax,nNum,nPresTmp,k,aNumBase
Dim aNumDaSvil,nQtNumDaSvil,aColDaPrendere,bFound
ReDim aBUsati(90)
Dim objSvil
Dim sKey
Dim cCombTmp
Dim nClasseSvilTmp
' inizializzo un nuovo motore di sviluppo
Set objSvil = GetMotoreSviluppoIntegrale
' leggo i numeri della combinazione base
aNumBase = cComb.ArrayNum
For k = 1 To cComb.Classe
aRetCol(k) = aNumBase(k)
aBUsati(aRetCol(k)) = True
Next
' faccio in clclo che dura fino a quando la lunghetta non arriva a contenere la quantità
' di numeri voluta
' la lunghetta parte con i numeri della combinazione base
' i numeri vengono aggiunti sviluppandoli con combinazioni di classe <nSorte>
' al termine del ciclo do sia avrà la combinazione migliore da aggiungere
' alla lunghetta base
' il giro continua finche la lunghetta non raggiunge la quantita di numeri voluti
nPos = cComb.Classe
Do While nPos < nClasse
' calcolo la classe per sviluppare le combinazioni da testare insieme ai numeri gia presenti
' nella lunghetta
' se possibile la classe di sviluppo è pari a <nSorte> senno viene calcolata e assume un valore inferiore
If nClasse - nPos >= nSorte Then
nClasseSvilTmp = nSorte
Else
nClasseSvilTmp = nClasse - nPos
End If
' predispongo la lunghetta per accogliere i numeri che otterremo dallo sviluppo
ReDim Preserve aRetCol(nPos + nClasseSvilTmp)
' individuo i numeri da sviluppare i quali devono avere la c aratteristica sia di essere usciti
' nelle estrazioni coinvolte dal range sia di non essere gia presenti nella lunghetta stessa
ReDim aNumDaSvil(90)
nQtNumDaSvil = 0
For n = 1 To 90
If Not(aBUsati(n)) Then
If abNumValidi(n) Then
nQtNumDaSvil = nQtNumDaSvil + 1
aNumDaSvil(nQtNumDaSvil) = n
End If
End If
Next
ReDim Preserve aNumDaSvil(nQtNumDaSvil)
' inizio a sviluppare le combinazioni da testare insieme ai numeri della lunghetta
ReDim aCol(nClasseSvilTmp)
bFound = False
Call objSvil.InitSviluppoIntegrale(aNumDaSvil,nClasseSvilTmp)
Do While objSvil.GetCombSviluppo(aCol)
' nelle opportune posizioni dell'array della lunghetta pongo i numeri della combinazione sviluppata
For k = 1 To nClasseSvilTmp
aRetCol(nPos + k) = aCol(k)
Next
' calcolo le presenze della lunghetta
nPresTmp = Presenze(aRetCol,nQtEstrUsate,UBound(aRetCol),aRuote,nSorte)
' se le presenze calcolate sono >= a quelle gia inidviduate allora
' devo tenere traccia della combinazione da prendere per inserirla
' nella lunghetta all'uscita del ciclo
If nPresTmp >= nPresMax Then
aColDaPrendere = aCol
nPresMax = nPresTmp
bFound = True
End If
Loop
' se ho trovato una combinazione da poter inserire nella lunghetta
' procedo ad inserirla e tengo traccia della nuova dimensione (quantita dei numeri)
' della lunghetta
' se non ho trovato niente è inutile continuare esce
If bFound Then
For k = 1 To nClasseSvilTmp
aRetCol(nPos + k) = aColDaPrendere(k)
aBUsati(aColDaPrendere(k)) = True
Next
nPos = nPos + nClasseSvilTmp
Else
Exit Do
End If
Loop
' se la lunghetta ha raggiunto la dimesnione prevista la funzione torna true
If nPos = nClasse Then
GetLung = True
Else
GetLung = False
End If
End Function
Sub AlimentaNumValidi(aCol,Inizio,Fine,aRuote,abNumValidi)
' funzione usata per test non nello script
'ReDim abNumValidi(90)
ReDim abNumValidi(0)
Dim quantitanumeriscelti
quantitanumeriscelti = ScegliNumeri(abNumValidi)
ReDim aNumRuota(5)
Dim idEstr,e,r
For idEstr = Inizio To Fine
For r = 1 To UBound(aRuote)
Call GetArrayNumeriRuota(idEstr,aRuote(r),aNumRuota)
If PuntiSuArray(aNumRuota,aCol) > 1 Then
For e = 1 To 5
abNumValidi(aNumRuota(e)) = True
Next
End If
Next
Next
End Sub
Function Presenze(aColDaSvilTmp,nQtEstrUsate,nClasseLunghetta,aRuote,Sorte)
' calcola le presenze di una lunghetta
Dim k,r,e,nPunti,aNumRuota,nPresenze
' Dim aB
nPresenze = 0
' aB = ArrayNumeriToBool(aColDaSvilTmp)
For k = 1 To nQtEstrUsate
For r = 1 To UBound(aRuote)
' Call GetArrayNumeriRuota(k,aRuote(r),aNumRuota)
nPunti = 0
For e = 1 To nClasseLunghetta
If aEstrattiBool(k,aRuote(r),aColDaSvilTmp(e)) Then
nPunti = nPunti + 1
End If
Next
If nPunti >= Sorte Then
nPresenze = nPresenze + 1
End If
Next
Next
Presenze = nPresenze
End FunctionIl sopra riportato script è molto efficiente per ricercare e ordinare le frequenze in ordine decrescente solo che valuta sempre e soltanto i 90 numeri mentre a me servirebbe appunto di implementarvi la tabella colorata per l'immissione dei numeri voluti di volta in volta.
Ho provato in mille e uno modi senza ahimè riuscirvi
Grazie 1000 a chi posterà la solution
Ps: A giudicare dalle numerose "istruzioni commentate" in esso presenti credo che l'abbia creato il Grande Maestro LuigiB, che saluto. Ad ogni modo è davvero molto ben fatto ed estremamente rapido nelle sue elaborazioni.
Ultima modifica:
