Per Mike58

solare · 23 Aprile 2018

Ciao, volevo chiederti se possibile, fare una modifica a questo tuo listato che svolge la ricerca per ambata
modificarlo ed effettuare la stessa ricerca per ambo.
Grazie infinite

Sub Main()
Dim nua(4005,16),nn(2)
'ee = DataEstrToIdEstr (31,12,2009)

ee = InputBox("DA QUALE DATA INIZIARE"," DATA ","31/12/2009")
ms = CInt(InputBox("In quale mese? ",,1))
If ms = "" Then Exit Sub
'r = CInt(InputBox("Di quale ruota? ",,5))
'If r = "" Then Exit Sub
'ru(1) = r
q = CInt(InputBox("Quanti ambi ed estratti vuoi visualizzare ? ",,10))
If q = "" Then Exit Sub
'
ReDim ru(0)
r = ScegliRuote(ru)
fin = EstrazioneFin
ResetTimer
'------------init tabella ------------------
ReDim atitoli(15)
atitoli(1) = " "
atitoli(2) = " Numero "
atitoli(3) = " Frequenza "
atitoli(4) = " Ritardo Attuale "
atitoli(5) = " Anno_2016 "
atitoli(6) = " Anno_2015 "
atitoli(7) = " Anno 2014 "
atitoli(8) = " Anno 2013 "
atitoli(9) = " Anno 2012 "
atitoli(10) = " Anno 2011 "
atitoli(11) = " Anno 2010 "
atitoli(12) = " Anno 2017 "
atitoli(13) = " Anno 2018 "
atitoli(14) = " Rit Sto "
atitoli(15) = " "
Call InitTabella(atitoli,1,,3,5)
For es = PrimaSuccessiva(ee) To fin
If Mese(es) = ms Then
co = 0
'For x = 1 To 89
'x = cg
'For y = x + 1 To 90
For x = 1 To 90
'If x <> y Then
co = co + 1
nua(co,1) = co
nua(co,2) = x
'nua(co,3) = y
nn(1) = x
'nn(2) = y
k = SerieFreqTurbo(es,es,nn,ru,1)
rt = SerieRitardoTurbo(Ini,fin,nn,ru,1)
rs = SerieStoricoTurbo(Ini,fin,nn,ru,1)
nua(co,4) = nua(co,4) + k
nua(co,5) = rt
nua(co,15) = rs
k1 = 0
If Anno(es) = 2016 Then k1 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,6) = nua(co,6) + k1
k2 = 0
If Anno(es) = 2015 Then k2 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,7) = nua(co,7) + k2
k3 = 0
If Anno(es) = 2014 Then k3 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,8) = nua(co,8) + k3
k4 = 0
If Anno(es) = 2013 Then k4 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,9) = nua(co,9) + k4
k5 = 0
If Anno(es) = 2012 Then k5 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,10) = nua(co,10) + k5
k6 = 0
If Anno(es) = 2011 Then k6 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,11) = nua(co,11) + k6
k7 = 0
If Anno(es) = 2010 Then k7 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,12) = nua(co,12) + k7
k8 = 0
If Anno(es) = 2017 Then k8 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,13) = nua(co,13) + k8
k9 = 0
If Anno(es) = 2018 Then k9 = SerieFreqTurbo(es,es,nn,ru,1)
nua(co,14) = nua(co,14) + k9

Next
'Next
End If
Next
OrdinaMatrice nua,- 1,4
ColoreTesto 2
Scrivi Space(10) & "Dal " & ee & " al " & DataEstrazione(fin),1
ColoreTesto 0
Scrivi "I " & q & " Numeri più frequenti " & " a " & StringaRuote(ru) & " nel mese di " & MeseNome(ms),1
Scrivi
For z = 1 To q
ReDim avalori(15)
avalori(1) = " "
avalori(2) = nua(z,2)
avalori(3) = nua(z,4)
avalori(4) = nua(z,5)
avalori(5) = nua(z,6)
avalori(6) = nua(z,7)
avalori(7) = nua(z,8)
avalori(8) = nua(z,9)
avalori(9) = nua(z,10)
avalori(10) = nua(z,11)
avalori(11) = nua(z,12)
avalori(12) = nua(z,13)
avalori(13) = nua(z,14)
avalori(14) = nua(z,15)
avalori(15) = " "
Call AddRigaTabella(avalori,,,3)
For xx = 5 To 12
Call SetColoreCella((xx),4,1)

If avalori(5) > 0 And avalori(6) > 0 And avalori(7) > 0 And avalori(8) > 0 And avalori(9) > 0 And avalori(10) > 0 And avalori(11) > 0 And avalori(12) > 0 Then
Call SetColoreCella((xx),6,1)
Call SetColoreCella(2,6,1)
End If
Next
'If avalori(5) = 0 And avalori(6) > 0 And avalori(7) > 0 And avalori(8) > 0 And avalori(9) > 0 Then Call SetColoreCella(2,vbGreen)
'If avalori(5) > 0 Then Call SetColoreCella(2,2,4)
'If rit = 0 Then Call SetColoreCella(4,3,2)
If avalori(4) = 0 Then Call SetColoreCella(4,3,2)
Call SetColoreCella(1,1,0)
Call SetColoreCella(15,1,0)
k11 = k11 + avalori(5)
k12 = k12 + avalori(6)
k13 = k13 + avalori(7)
k14 = k14 + avalori(8)
k15 = k15 + avalori(9)
k16 = k16 + avalori(10)
k17 = k17 + avalori(11)
k18 = k18 + avalori(12)
k19 = k19 + avalori(13)
'riga = Format2(nua(z,2)) & "-" & Format2(nua(z,3)) & Space(3) & Format2(nua(z,4)) & Space(10) & Format2(nua(z,5))
'Scrivi Space(10) & riga,1
'riga = ""
Next
ReDim avalori1(15)
avalori1(1) = " "
avalori1(5) = k11
avalori1(6) = k12
avalori1(7) = k13
avalori1(8) = k14
avalori1(9) = k15
avalori1(10) = k16
avalori1(11) = k17
avalori1(12) = k18
avalori1(13) = k19
Call AddRigaTabella(avalori1,1,,3,5)
Call SetTableWidth("100%")
Call CreaTabella()
Scrivi "Tempo di Elaborazione : " & TempoTrascorso
Scrivi " Tabella listed by Mike58 ",1,- 1,3
End Sub

Mike58 · 23 Aprile 2018

Ciao Solare, io te lo trasformo per gli Ambi, ma i tempi di elaborazione sono molto lunghi su ruota.
Fallo andare a fine elaborazione io l'ho stoppato a 10 min , dovrebbe andare.....

Luigi aveva fatto uno script simile molto + veloce (mi sa che te lo avevo consigliato di già... Cercalo)

intanto prova così.

Codice:

Sub Main()
   Dim nua(4005,16),nn(2)
   'ee = DataEstrToIdEstr (31,12,2009)
   ee = InputBox("DA QUALE DATA INIZIARE"," DATA ","31/12/2009")
   ms = CInt(InputBox("In quale mese? ",,1))
   If ms = "" Then Exit Sub
   'r = CInt(InputBox("Di quale ruota? ",,5))
   'If r = "" Then Exit Sub
   'ru(1) = r
   q = CInt(InputBox("Quanti ambi ed estratti vuoi visualizzare ? ",,10))
   If q = "" Then Exit Sub
   '
   ResetTimer
   ReDim ru(0)
   r = ScegliRuote(ru)
   fin = EstrazioneFin
   ResetTimer
   '------------init tabella ------------------
   ReDim atitoli(15)
   atitoli(1) = " "
   atitoli(2) = " Numero "
   atitoli(3) = " Frequenza "
   atitoli(4) = " Ritardo Attuale "
   atitoli(5) = " Anno_2016 "
   atitoli(6) = " Anno_2015 "
   atitoli(7) = " Anno 2014 "
   atitoli(8) = " Anno 2013 "
   atitoli(9) = " Anno 2012 "
   atitoli(10) = " Anno 2011 "
   atitoli(11) = " Anno 2010 "
   atitoli(12) = " Anno 2017 "
   atitoli(13) = " Anno 2018 "
   atitoli(14) = " Rit Sto "
   atitoli(15) = " "
   Call InitTabella(atitoli,1,,3,5)
   For es = PrimaSuccessiva(ee) To fin
      If Mese(es) = ms Then
         co = 0
         For x = 1 To 89
         'x = cg
         For y = x + 1 To 90
         'For x = 1 To 90
            'If x <> y Then
            co = co + 1
            nua(co,1) = co
            nn(1) = x
            nn(2) = y
            nua(co,2) = StringaNumeri(nn)
           ' nua(co,3) = y

            k = SerieFreqTurbo(es,es,nn,ru,2)
            rt = SerieRitardoTurbo(Ini,fin,nn,ru,2)
            rs = SerieStoricoTurbo(Ini,fin,nn,ru,2)
            nua(co,4) = nua(co,4) + k
            nua(co,5) = rt
            nua(co,15) = rs
            k1 = 0
            If Anno(es) = 2016 Then k1 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,6) = nua(co,6) + k1
            k2 = 0
            If Anno(es) = 2015 Then k2 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,7) = nua(co,7) + k2
            k3 = 0
            If Anno(es) = 2014 Then k3 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,8) = nua(co,8) + k3
            k4 = 0
            If Anno(es) = 2013 Then k4 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,9) = nua(co,9) + k4
            k5 = 0
            If Anno(es) = 2012 Then k5 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,10) = nua(co,10) + k5
            k6 = 0
            If Anno(es) = 2011 Then k6 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,11) = nua(co,11) + k6
            k7 = 0
            If Anno(es) = 2010 Then k7 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,12) = nua(co,12) + k7
            k8 = 0
            If Anno(es) = 2017 Then k8 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,13) = nua(co,13) + k8
            k9 = 0
            If Anno(es) = 2018 Then k9 = SerieFreqTurbo(es,es,nn,ru,2)
            nua(co,14) = nua(co,14) + k9
            Call Messaggio("Tempo di Elaborazione : " & TempoTrascorso)
            Call AvanzamentoElab(Ini,fin,es)
         Next
         Next
         If ScriptInterrotto Then Exit For
      End If
   Next
   OrdinaMatrice nua,- 1,4
   ColoreTesto 2
   Scrivi Space(10) & "Dal " & ee & " al " & DataEstrazione(fin),1
   ColoreTesto 0
   Scrivi "I " & q & " Numeri più frequenti " & " a " & StringaRuote(ru) & " nel mese di " & MeseNome(ms),1
   Scrivi
   For z = 1 To q
      ReDim avalori(15)
      avalori(1) = " "
      avalori(2) = nua(z,2)
      avalori(3) = nua(z,4)
      avalori(4) = nua(z,5)
      avalori(5) = nua(z,6)
      avalori(6) = nua(z,7)
      avalori(7) = nua(z,8)
      avalori(8) = nua(z,9)
      avalori(9) = nua(z,10)
      avalori(10) = nua(z,11)
      avalori(11) = nua(z,12)
      avalori(12) = nua(z,13)
      avalori(13) = nua(z,14)
      avalori(14) = nua(z,15)
      avalori(15) = " "
      Call AddRigaTabella(avalori,,,3)
      For xx = 5 To 12
         Call SetColoreCella((xx),4,1)
         If avalori(5) > 0 And avalori(6) > 0 And avalori(7) > 0 And avalori(8) > 0 And avalori(9) > 0 And avalori(10) > 0 And avalori(11) > 0 And avalori(12) > 0 Then
            Call SetColoreCella((xx),6,1)
            Call SetColoreCella(2,6,1)
         End If
      Next
      'If avalori(5) = 0 And avalori(6) > 0 And avalori(7) > 0 And avalori(8) > 0 And avalori(9) > 0 Then Call SetColoreCella(2,vbGreen)
      'If avalori(5) > 0 Then Call SetColoreCella(2,2,4)
      'If rit = 0 Then Call SetColoreCella(4,3,2)
      If avalori(4) = 0 Then Call SetColoreCella(4,3,2)
      Call SetColoreCella(1,1,0)
      Call SetColoreCella(15,1,0)
      k11 = k11 + avalori(5)
      k12 = k12 + avalori(6)
      k13 = k13 + avalori(7)
      k14 = k14 + avalori(8)
      k15 = k15 + avalori(9)
      k16 = k16 + avalori(10)
      k17 = k17 + avalori(11)
      k18 = k18 + avalori(12)
      k19 = k19 + avalori(13)
      'riga = Format2(nua(z,2)) & "-" & Format2(nua(z,3)) & Space(3) & Format2(nua(z,4)) & Space(10) & Format2(nua(z,5))
      'Scrivi Space(10) & riga,1
      'riga = ""
   Next
   ReDim avalori1(15)
   avalori1(1) = " "
   avalori1(5) = k11
   avalori1(6) = k12
   avalori1(7) = k13
   avalori1(8) = k14
   avalori1(9) = k15
   avalori1(10) = k16
   avalori1(11) = k17
   avalori1(12) = k18
   avalori1(13) = k19
   Call AddRigaTabella(avalori1,1,,3,5)
   Call SetTableWidth("100%")
   Call CreaTabella()
   Scrivi "Tempo di Elaborazione : " & TempoTrascorso
   Scrivi " Tabella listed by Mike58 ",1,- 1,3
End Sub

ecco trovato script di luigi

Codice:

Option Explicit
Class ClsCombinazione
Private aNumeri
Private aRuote
Private m_ritardo
Private m_frequenza
Private m_ritardoMax
Private m_sorte
Private m_EstrIni
Private m_EstrFin
Public Property Get Ruote
Ruote = aRuote
End Property
Public Property Get Sorte
Sorte = m_sorte
End Property
Public Property Get EstrIni
EstrIni = m_EstrIni
End Property
Public Property Get EstrFin
EstrFin = m_EstrFin
End Property
Public Property Get Ritardo
Ritardo = m_ritardo
End Property
Public Property Get Frequenza
Frequenza = m_frequenza
End Property
Public Property Get RitardoMax
RitardoMax = m_ritardoMax
End Property
Sub EseguiStat(vNumeri,vRuote,Sorte,Inizio,Fine)
Dim nColTot,r
ReDim aR(1)
aNumeri = vNumeri
aRuote = vRuote
m_sorte = Sorte
m_EstrIni = Inizio
m_EstrFin = Fine
m_ritardo = 0
m_frequenza = 0
m_ritardoMax = 0
Call StatisticaFormazioneTurbo(aNumeri,aRuote,m_sorte,m_ritardo,m_ritardoMax,0,m_frequenza,m_EstrIni,m_EstrFin)
End Sub
Function StringaNum
StringaNum = StringaNumeri(aNumeri)
End Function
End Class
Sub Main
Dim nQNum,nSorte,Inizio,Fine,nFisso,idMese,nEstrAna
Dim Coll,clsCmb
Dim R,j
Dim idTipoRic
ReDim aNumeri(0)
ReDim aVTable(11)
ReDim abMesi(12)
Dim aVTipoRic
aVTipoRic = Array("Frequenza","Ritardo","RitardoMax")
idMese = ScegliMese
abMesi(idMese) = True
nFisso = Sceglifisso
aVTable(1) = "Ruota"
ResetTimer

For R = 2 To 11
aVTable(R) = "A" & R - 1
Next
Call InitTabella(aVTable)
Inizio = 3950'EstrazioneIni
Fine = EstrazioneFin
nQNum = ScegliNumeri(aNumeri)
nSorte = ScegliEsito(2)
idTipoRic = ScegliTipoRicerca
nEstrAna = AttivaEstrazioni(Inizio,Fine,abMesi)
For R = 1 To 12
'If R <> 11 Then
aVTable(1) = NomeRuota(R)
Call Messaggio(aVTable(1))
Set Coll = GetNewCollection
Call EseguiStatistica(nFisso,aNumeri,R,nSorte,nSorte,Inizio,Fine,Coll)
Call OrdinaItemCollection(Coll,aVTipoRic(idTipoRic))
'For j = 2 To 11
For j = 2 To Coll.count + 1
If j > 11 Then Exit For
Set clsCmb = Coll(j - 1)
If aVTipoRic(idTipoRic) = "Frequenza" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Frequenza & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "Ritardo" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Ritardo & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "RitardoMax" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.RitardoMax & "</font>)"
End If
Next
Call AddRigaTabella(aVTable)
'End If
Call AvanzamentoElab(1,12,R)
Next
SetTableWidth("100%")
Call Scrivi("Range analizzato : " & GetInfoEstrazione(Inizio) & " - " & GetInfoEstrazione(Fine))
Call Scrivi("Numero fisso     ; " & Iif(nFisso = 0,"Nessuno",nFisso))
Call Scrivi("Mese analizzato  : " & Iif(idMese = 0,"Tutti",MeseNome(idMese)))
Call Scrivi("Estrazioni tot,  : " & nEstrAna)
Call Scrivi(String(100,"-"))
Call CreaTabella
Scrivi "Tempo di Elaborazione : " & TempoTrascorso,1

End Sub
Sub EseguiStatistica(nFisso,vNumeri,nRuota,Classe,Sorte,Inizio,Fine,CollDest)
Dim nColTot
Dim cComb
ReDim aFissi(1)
aFissi(1) = nFisso
ReDim aR(1)
aR(1) = nRuota
If aFissi(1) > 0 Then
nColTot = InitSviluppoIntegrale(vNumeri,Classe,aFissi)
Else
nColTot = InitSviluppoIntegrale(vNumeri,Classe)
End If
ReDim aCol(0)
Do While GetCombSviluppo(aCol)
Set cComb = New ClsCombinazione
Call cComb.EseguiStat(aCol,aR,Sorte,Inizio,Fine)
CollDest.Add cComb
Loop
End Sub
Private Function MeseValido(idEstr,aMesi)
If aMesi(0) Then
MeseValido = True
Else
MeseValido = aMesi(Mese(idEstr))
End If
End Function
Private Function AttivaEstrazioni(Inizio,fine,aMesi)
Dim k
Dim nValide,b
nValide = 0
For k = Inizio To fine
b = MeseValido(k,aMesi)
Call ImpostaEstrazione(k,CBool(b))
If b Then
nValide = nValide + 1
End If
Next
AttivaEstrazioni = nValide
End Function
Function ScegliMese
Dim aV
aV = Array("Tutti","Gen","Feb","Mar","Apr","Mag","Giu","Lug","Ago","Set","Ott","Nov","Dic")
ScegliMese = ScegliOpzioneMenu(aV,0)
End Function
Function Sceglifisso
ReDim aV(90)
Dim k
aV(0) = "Nessun fisso"
For k = 1 To 90
aV(k) = k
Next
Sceglifisso = ScegliOpzioneMenu(aV,0)
End Function
Function ScegliTipoRicerca
Dim aV
aV = Array("Frequenza","Ritardo","RitardoMax")
ScegliTipoRicerca = ScegliOpzioneMenu(aV,0)
End Function

solare · 23 Aprile 2018

Ciao Mike58, grazie infinite della tua gentilezza

solare · 23 Aprile 2018

Ok Mike58, funziona ho elaborato in circa 4 minuti
Grazie ancora

zagort · 23 Aprile 2018

non riuscendo a ringraziarti privatamente........pubblicamente un grosso grazie

Mike58 · 24 Aprile 2018

Ciao Solare Bene.
ciao Zagort,neanche io ero riuscito a raggiungerti in privato, ma vedo che comunque hai ricevuto.

Cerca

Cerca

Per Mike58

solare

Advanced Member >PLATINUM<

Mike58

Advanced Member >PLATINUM PLUS<

solare

Advanced Member >PLATINUM<

solare

Advanced Member >PLATINUM<

zagort

Super Member >PLATINUM<

Mike58

Advanced Member >PLATINUM PLUS<

Ultima estrazione Lotto

Ultimi Messaggi