Velocizzare macro

[Statix]

Ciao a tutti, ho sempre avuto problemi per velocizzare le macro,
quindi la solita solfa, lotto e velocità.
In E10:I1809 ho 1800 estrazioni, in caso si velocizza la macro aumento le estrazioni anche a 3000 e più
In P8:S8 ho la quartina da verificare sulle estrazioni E10:I1809
in K10 :K1809

Codice: Seleziona tutto

=SE(SOMMA(CONTA.SE(E10:I10;$P$8:$S$8))>=1;1;"")

formula matrice
in M10:M1809

Codice: Seleziona tutto

=SE(K10=1;0;M9+1)

in W6 c'è il valore filtro, se lo storico è < = allora copia la quartina
naturalmente in P8:S8 girano tutte le quartine 2.555.190
allego il file funzionante ma lento impiega diverse ore


http://www.filedropper.com/quartinexambata5

[Anthony47]

Perdona, in genere per velocizzare un processo bisogna cambiare approccio.
Questo pero' presuppone che si sappia che cosa vorresti ottenere partendo da quei dati; ti chiedo quindi di spiegare questa cosa senza doverli andare a desumere dalle formule e dalla macro che hai usato

Ciao

[Statix]

Ciao Anthony47,
credevo che con il file ti era più facile capire, comunque riepilogo cosa fare,
in E10:I1809 ho 1800 estrazioni,
la macro con una serie di cicli sviluppa tutte le quartine dei 90 numeri 2.555.190 combinazioni
in P8:S8
esempio la prima quartina 1-2-3-4 in P8:S8 verifica a confronto di ogni singola estrazione l'uscita di un o più numeri con la formula matrice in K10
copiandola fino all'ultima estrazione

Codice: Seleziona tutto

=SE(SOMMA(CONTA.SE(E10:I10;$P$8:$S$8))>=1;1;"")

dopo con la formula in M10

Codice: Seleziona tutto

=SE(K10=1;0;M9+1)

copiandola in basso fino alle 1800 estrazioni
alla fine in M 1809 ho il ritardo attuale della quartina, poi con max M10:M1809 prendo il valore più alto,
questo valore viene filtrato dal valorein W6 in questo caso 16, se il valore della cella W8 è minore o uguale a 16 mi memorizza la quartina ,l' attuale e il max. vedi immagine .

[Anthony47]

Purtroppo mi hai ripetuto coma hai fatto tu a fare l'elaborazione, mentre io avrei voluto sapere che elaborazione andava fatta, riservandomi di scegliere l'algoritmo a mio parere piu' idoneo.
Quindi al momento posso solo proporre un modo piu' veloce di fare gli stessi calcoli, ribadendo pero' che non so valutare se l'approccio adottato sia il modo piu' logico e piu' veloce.
Corrisponde a questa macro:

Codice: Seleziona tutto

Sub Boh12()
Dim I As Long, J As Long, K As Long, L As Long, IQ As Long
Dim qArr(1 To 4), aCnt As Long, hCnt As Long, cCnt As Long
Dim oArr()
Dim wArr, Soglia As Long
'
ReDim oArr(1 To 8, 1 To 1)
wArr = Range("E10").CurrentRegion.Value
mytim = Timer
IQ = 1
Soglia = Range("W6").Value
Range("P10:W100000").ClearContents
For I = 1 To 87
    qArr(1) = I
    For J = I + 1 To 88
        qArr(2) = J
        For K = J + 1 To 89
            qArr(3) = K
            For L = K + 1 To 90
                qArr(4) = L
                cnt = cnt + 1: cCnt = 0: hCnt = 0
                For ii = 1 To UBound(wArr)
                    aCnt = 0
                    For jj = 1 To 5
                        If wArr(ii, jj) = qArr(1) Then
                            aCnt = aCnt + 1
                        ElseIf wArr(ii, jj) = qArr(2) Then
                            aCnt = aCnt + 1
                        ElseIf wArr(ii, jj) = qArr(3) Then
                            aCnt = aCnt + 1
                        ElseIf wArr(ii, jj) = qArr(4) Then
                            aCnt = aCnt + 1
                        End If
                        If aCnt >= 1 Then Exit For
                    Next jj
                    If aCnt >= 1 Then
                        If cCnt > hCnt Then hCnt = cCnt
                        cCnt = 0
                    Else
                        cCnt = cCnt + 1
                    End If
                Next ii
'Solo per debug:
''                If cnt > 10000 Then
''                    aaaa = Timer - mytim
''                    Range("P10").Resize(IQ, 8) = Application.WorksheetFunction.Transpose(oArr)
''                    Stop
''                End If
                If hCnt <= Soglia Then
                    ReDim Preserve oArr(1 To 8, 1 To IQ + 1)
                    oArr(1, IQ) = qArr(1)
                    oArr(2, IQ) = qArr(2)
                    oArr(3, IQ) = qArr(3)
                    oArr(4, IQ) = qArr(4)
                    oArr(6, IQ) = cCnt
                    oArr(8, IQ) = hCnt
                    IQ = IQ + 1
                End If
            Next L
        Next K
    Next J
Next I
Range("P10").Resize(IQ, 8) = Application.WorksheetFunction.Transpose(oArr)
MsgBox ("Completato...")
End Sub

Da prove fatte risulterebbe circa 70 volte piu' veloce della tua, ma i tempi STIMATI complessivi di esecuzione sono sempre dell'ordine di "Ore" (direi circa 1.5 ore); poiche' anche tu parlavi di "diverse ore" per l'esecuzione completa non so valutare l'efficacia' di quanto proposto.
Raddoppiando la lunghezza dei dati di partenza i tempi di esecuzione aumentano in proporzione diretta.

Ciao

[Statix]

Cia Anthony47,
ho provato la macro, il tempo di esecuzione impiega un ora e 15 minuti, come da te previsto, anche se i tempi sono ancora altini,
ho trovato un piccolo inconveniente , ci sono alcune quartine che mancano, dopo un attento sguardo ,ho capito il motivo,
se la somma della quartina e l'estrazione è maggiore di 1 non viene filtrata, quindi esclusa
infatti la formula che usavo >=1;1

Codice: Seleziona tutto

=SE(SOMMA(CONTA.SE(E10:I10;$P$8:$S$8))>=1;1;"")


inoltre volevo aggiungere un altro filtro range U6>= U8 , valore in U8 = 7

Codice: Seleziona tutto

if Range("W8") <= Range("W6") And Range("U8") >= Range("U6") Then

Codice: Seleziona tutto

1   10   26   27      7      16
1   21   27   86      3      16
2   12   69   82      0      16
2   17   27   69      2      16
2   17   69   82      2      16

[Anthony47]

Non ho capito se hai un miglioramento o meno

ho trovato un piccolo inconveniente , ci sono alcune quartine che mancano, dopo un attento sguardo ,ho capito il motivo, se la somma della quartina e l'estrazione è maggiore di 1 non viene filtrata, quindi esclusa

Non capisco la frase "se la somma della quartina e l'estrazione è maggiore di 1 non viene filtrata, quindi esclusa" perche' la macro non fa nessuna somma delle quartine ma si limita a controllare che nelle estrazioni ci sia almeno un numero appartenente alla quartina.
Comunque se mi fai un esempio di quartina mancante e mi dici quale risultato dovrebbe esserci in colonna U e W magari capisco...

Quanto alla modifica chiesta, devi fare questa aggiunta:

Codice: Seleziona tutto

Soglia = Range("W6").Value
Soglia1 = Range("U6").Value             '+++AGGIUNGI
Range("P10:W100000").ClearContents


e questa modifica:

Codice: Seleziona tutto

                End If
                If hCnt <= Soglia And cCnt >= Soglia1 Then     'MMM Modificata
                    ReDim Preserve oArr(1 To 8, 1 To IQ + 1)


Ciao

[Statix]

Ciao Anthony47,
alcune quartine mancanti,

Codice: Seleziona tutto

1   10   26   27      7      16
1   21   27   86      3      16
2   12   69   82      0      16
2   17   27   69      2      16
2   17   69   82      2      16


il motivo del perchè mancano e che nel confronto tra la cinquina e la quartina i numeri uguali sono più di 1
nella cella in giallo la formula applicata è

Codice: Seleziona tutto

=SE(SOMMA(CONTA.SE(E90:I90;$P$8:$S$8))>=1;1;"")

quindi nella tua macro non filtra questa quartina, ho provato a capire in quale riga di codice dove modificare con >=1 senza riuscirci

[Statix]

ok stò controllando

[Statix]

trovato una quartina strana nel senso non valida
5-6-73-86 attuale 20 max16 in realtà il max è 20 quindi la quartina doveva essere scartata,

[Anthony47]

Non capisco se nel tuo linguaggio "filtrare" significa Nascondere o Evidenziare; quindi non usero' questo termine.

Il file esamina, per ogni combinazione di 4 numeri (chiamiamole "quartine"), se in ognuna delle estrazioni elencate (colonne E:I) figura almeno 1 numero della quartina; da questo primo dato viene calcolato il ritardo corrente (in U8) e il ritardo max (in W8).
La logica del tuo file e' che solo le quartine che hanno un "ritardo max (W8)" Minore o Uguale alla "soglia" scritta in W6 vengono trascritte in colonne P:S

Le 4 quartine che porti come esempio hanno tutte, usando le estrazioni e la logica del tuo file, un ritardo max superiore a 16 che tu hai usato come "soglia":

Codice: Seleziona tutto

--------------------------------Rit Max
1   10   26   27      7      16--->19
1   21   27   86      3      16--->20
2   12   69   82      0      16--->21
2   17   27   69      2      16--->20
2   17   69   82      2      16--->20

Questo e' il motivo per cui non compaiono in elenco finale

Quanto al caso in cui il ritardo corrente sia il rit max, per la sua gestione dobbiamo aggiungere questa riga in questa posizione:

Codice: Seleziona tutto

                End If
                If cCnt > hCnt Then hCnt = cCnt                'AGGIUNGERE per Correzione Max su Finale
                If hCnt <= Soglia And cCnt >= Soglia1 Then     'MMM Modificata (gest. 2° Soglia)
                    ReDim Preserve oArr(1 To 8, 1 To IQ + 1)


Ciao

[Statix]

Ciao Anthony47,
ho fatto le modifiche, e testato la macro, tutto ok,
fatto anche riscontro con i miei dati ,l'unico problema sono i tempi di elaborazione ancora lunghi.
grazie di tutto .

[Anthony47]

Io finora non so quale e' l'obiettivo di questo calcolo, mi sono limitato a rifare in altro modo le stesse cose che fa il tuo file; e non ho nemmeno capito se c'e' un miglioramento e di quanto, visto che di ore si parlava all'inizio e oltre un'ora siamo adesso.
Se invece mi dici l'obiettivo magari riesco a pensare di ottenerlo in modo diverso

Ciao

[Statix]

Ciao Anthony47,

la logica è esattamente quella che hai scritto, ed è ciò che io volevo fare,

Il file esamina, per ogni combinazione di 4 numeri (chiamiamole "quartine"), se in ognuna delle estrazioni elencate (colonne E:I) figura almeno 1 numero della quartina; da questo primo dato viene calcolato il ritardo corrente (in U8) e il ritardo max (in W8).
La logica del tuo file e' che solo le quartine che hanno un "ritardo max (W8)" Minore o Uguale alla "soglia" scritta in W6 vengono trascritte in colonne P:S

ma i tempi erano lunghissimi tante vero che non sono mai andato in fondo per capire il tempo esatto , penso una decina di ore mentre con la tua macro faccio il tutto in un ora e 15 minuti, tempi abbastanza soddisfacenti. se si riesce ad abbassare ancora ulteriormente i tempi, ben venga, grazie.

[Dylan666]

Posso andare leggermente fuori tema?
Hai mai pensato di imparare quel poco di Python che ti serve per fare queste cose?

[Statix]

Ciao Dylan666,
onestamente di Python ne ho sentito parlare da qualche amico programmatore,
io personalmente non so neanche come è fatto, comunque ti ringrazio per la dritta,
vedo di informarmi al riguardo.
in passato ho tentato con il basic e con visual basic, comprato mattoni di libri ,
ma senza successo un po' complicato essere autodidatta, mentre con excel riesco di più.

[Dylan666]

il problema è che continui a cercare in programmi visuali quelli che sono calcoli meramente matematici.
Premesso che Python ha spesso funzioni apposite per ricorrenze e conteggi, anche se facessi i cicli annidati scommetto che sarebbe molto più veloce.
la logica è: ti do un prima sequenza di numeri (le estrazioni) e una seconda (le possibili quaterne) e tu mi conti quante volte hai trovato il secondo gruppo nel primo.
L'output sarebbe una lista di numeri (le ricorrenze) che facilmente poi filtri come ti pare in Excel.

[Statix]

Ciao Dylan666,
ho scaricato ultima versione di Python per windows
e installato, mi sembra un editor di testo,
credo che dovrò scaricare anche help per capirci qualcosa,
hai già qualche idea ? visto la logica

[Dylan666]

Posso darti degli spunti, non sono un esperto.
Fra l'altro passiamo dall'argomento "Applicazione Office Windows" a "Programmazione" e forse un forum verticale solo Python sarebbe ancora più adatto (poi magari ci sono espertissimi pure qui, non lo so).
Comunque, uno spunto è questo:
https://www.techbeamers.com/program-pyt ... -elements/

Già "all()" nasce per vedere se i valori di una lista (ogni quaterna possibile) è contenuta in un'altra lista (ogni estrazione possibile).
Già questo ti fa capire come i cicli da uno per ogni numero di estrazione e quaterna diventa solo uno per ogni insieme di numeri

[Anthony47]

Se il problema fosse di indagare quali quaterne sono uscite e il loro ritardo sarebbe tutto risolto in 3 minuti.
Invece nella discussione si vuole indagare ogni singolo numero delle possibili quartine...

[Anthony47]

Con un po' di pazienza ho elaborato questa nuova versione, che usa un differente algoritmo per fare gli stessi calcoli:

Codice: Seleziona tutto

Sub QuartinQua()
Dim N90() As Boolean,  wArr, I As Long, J As Long, K As Long, L As Long
Dim oArr(), oDest As String, myTim As Single, IQ As Long
Dim Riduz As Long, iI As Long, SogliA As Long, Soglia1 As Long
Dim aCnt As Long, oCnt As Long, hCnt As Long
'
SogliA = Range("W6").Value
Soglia1 = Range("U6").Value
'
oDest = "Y10"                   '<<< L'inizio dell'area dei risultati
myTim = Timer
Range(oDest).Resize(10000, 9).ClearContents
'
wArr = Range("E10").CurrentRegion.Value
ReDim N90(1 To UBound(wArr), 1 To 90)
IQ = 1
ReDim oArr(1 To 8, 1 To IQ)
'Compila N90:
For I = 1 To UBound(wArr)
    For J = 1 To UBound(wArr, 2)
        N90(I, wArr(I, J)) = True
    Next J
Next I
Dim QQQ As Boolean
Riduz = 0       'Modificare solo per test!
For I = 1 To 87 - Riduz
    For J = I + 1 To 88 - Riduz
        For K = J + 1 To 89 - Riduz
            For L = K + 1 To 90 - Riduz
                'Calcolo ritardi attingendo a N90:
                aCnt = 0: oCnt = 0: hCnt = 0
                For iI = 1 To UBound(N90)
                    If N90(iI, I) Then
                        QQQ = True
                    ElseIf N90(iI, J) Then
                        QQQ = True
                    ElseIf N90(iI, K) Then
                        QQQ = True
                    ElseIf N90(iI, L) Then
                        QQQ = True
                    End If
                    If QQQ Then
                        aCnt = iI - oCnt - 1
                        If aCnt > hCnt Then hCnt = aCnt
                        oCnt = iI
                        aCnt = 0
                    End If
                    QQQ = False
                Next iI
                'Resume
                aCnt = iI - oCnt - 1
                If aCnt > hCnt Then hCnt = aCnt
                If hCnt <= SogliA And aCnt >= Soglia1 Then     'Confronto prima e seconda Soglia
                    ReDim Preserve oArr(1 To 8, 1 To IQ + 1)
                    oArr(1, IQ) = I
                    oArr(2, IQ) = J
                    oArr(3, IQ) = K
                    oArr(4, IQ) = L
                    oArr(6, IQ) = aCnt
                    oArr(8, IQ) = hCnt
                    IQ = IQ + 1
                End If
'                QQQ = False
            Next L
        Next K
    Next J
DoEvents
Next I
'Output:
Range(oDest).Resize(IQ, 8) = Application.WorksheetFunction.Transpose(oArr)
MsgBox ("Completato, " & Format(Timer - myTim, "0.00"))
End Sub


A spanne mi pare che i tempi siano ridotti a circa 1/12.
Questa sub posiziona i risultati a partire da Y10, in modo da confrontarli con quanto ottenuto dalla sub precedente. Per impostare l'area dei risultati bisogna modificare l'istruzione marcata <<< verso l'inizio.

Prova anche tu...