Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

Trova 4005 Coppie Numeri In Archivio

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Trova 4005 Coppie Numeri In Archivio

Postdi ikwae » 17/10/20 20:49

Ciao a tutti… Vorrei velocizzare la mia macro “casareccia” che per :oops: non la pubblico e aggiungo che è talmente contorta che sicuramente a “leggerla” creerà non poca confusione. Ma se richiesta la posto.

Mi rivolgo a tutti coloro che mi possono aiutare a scrivere una macro che esegue i seguenti passi.

1) Copiare la 1à coppia di numeri in colonna O2:P2 (1 e 2) e incollarla sul foglio Posa_Coppia a partire dalla cella A1.

2) Inizia la ricerca riga per riga dell’archivio a partire dalla cella F2:J(end)
2.1) Se trova la coppia dei numeri in riga, copiare la riga dalla colonna B fino alla K e accodarla sul foglio Posa_Coppia a partire dalla cella A1. Continuare fino a fine archivio
2.2) Se non trova nulla prosegue con la prossima coppia di numeri

3) Copiare la 2à coppia di numeri in colonna O3:P3 (1 e 3) e incollarla sul foglio Posa_Coppia a partire dalla cella A1.

2) Inizia la ricerca riga per riga dell’archivio a partire dalla cella F2:J(end)
2.1) Se trova la coppia dei numeri in riga, copiare la riga dalla colonna B fino alla K e accodarla sul foglio Posa_Coppia a partire
dalla cella A1. Continuare fino a fine archivio
2.2) Se non trova nulla prosegue con la prossima coppia di numeri

4) Copiare la 3à coppia di numeri in colonna O4:P4 (1 e 4) e incollarla sul foglio Posa_Coppia a partire dalla cella A1.

2) Inizia la ricerca riga per riga dell’archivio a partire dalla cella F2:J(end)
2.1) Se trova la coppia dei numeri in riga, copiare la riga dalla colonna B fino alla K e
accodarla sul foglio Posa_Coppia a partire dalla cella A1. Continuare fino a fine archivio
2.2) Se non trova nulla prosegue con la prossima coppia di numeri

“ “ “ “
“ “ “ “
4005) Copiare l’ultima coppia di numeri in colonna O4006:P4006 (89 e 90) e incollarla sul
foglio Posa_Coppia a partire dalla cella A1.

2) Inizia la ricerca riga per riga dell’archivio a partire dalla cella F2:J(end)
2.1) Se trova la coppia dei numeri in riga, copiare la riga dalla colonna B fino alla K e
accodarla sul foglio Posa_Coppia a partire dalla cella A1. Continuare fino a fine archivio

Se può essere utile posso dire che le coppie dei numeri in colonna O2:P4006 sono le famose coppie 4005 di numeri ossia ambi che si formano dai 90 numeri senza ripetizioni.

Quando la macro ha finito, sul foglio Posa_Coppia, dovrebbero essere scritte 267.015 righe come è visibile dal foglio Fine.

Quando la macro è finita vorrei poter chiedere una piccola modifica, se possibile, scriverlo adesso creerei soltanto confusione.

Note: I numeri dell’archivio sono numeri personalizzati ossia generati dal mio programma ricavati dall’archivio di ogni ruota quindi non reali alle estrazioni indicate dalle date e concorsi.

in allegato un file con tre fogli;
uno Archivio dove deve lavorare la macro di aiuto
uno Posa_Coppia dove vanno incollate le istanze trovare nell'archivio
uno Fine dove c'è il risultato della mia macro dopo 8 ore circa di lavoro.

Ringraziando in anticipo tutti coloro che mi possono aiutare. 73 ikwae
http://www.filedropper.com/trova4005cop ... chiviorete
Excel 2007
Avatar utente
ikwae
Utente Senior
 
Post: 192
Iscritto il: 27/12/17 23:14

Sponsor
 

Re: Trova 4005 Coppie Numeri In Archivio

Postdi Anthony47 » 19/10/20 00:52

Eccomi a fare la prima buona azione settimanale.

Penso che questa macro potrebbe dare i risultati che cerchi:
Codice: Seleziona tutto
Sub BuonAzione231()
Dim oArr(), wArr, oInd
Dim N1 As Long, N2 As Long, I As Long
Dim ASh As Worksheet, PCSh As Worksheet
Dim LI As Long, LJ As Long, LArr(1 To 10)
Dim mN1, mN2
Dim aAmbi(1 To 90, 1 To 90) As Long, LK As Long, LL As Long
Dim iAmbo As Long, cAmbos As Long
'
Set ASh = Sheets("Archivio")            '<<< Il foglio coi dati
Set PCSh = Sheets("Posa_Coppia")        '<<< Il foglio dei risultati
'
myTim = Timer
PCSh.Range("A:K").ClearContents
I = ASh.Cells(Rows.Count, "B").End(xlUp).Row
wArr = ASh.Range("B2").Resize(I, 10).Value
'
ReDim oArr(1 To (I * 10 + 4100), 1 To 10)
'Qualche informazione su quel che ci aspetta:
For LI = LBound(wArr) To UBound(wArr) - 1
    For LJ = 5 To 8
        For LK = LJ + 1 To 9
        If wArr(LI, LJ) = 90 And wArr(LI, LK) = 90 Then Stop
            aAmbi(wArr(LI, LJ), wArr(LI, LK)) = aAmbi(wArr(LI, LJ), wArr(LI, LK)) + 1
            aAmbi(wArr(LI, LK), wArr(LI, LJ)) = aAmbi(wArr(LI, LK), wArr(LI, LJ)) + 1
        Next LK
    Next LJ
Next LI
cAmbos = 1
For LI = 1 To 89
    For LJ = LI + 1 To 90
        iAmbo = iAmbo + 0 + cAmbos
        oArr(iAmbo, 1) = LI: oArr(iAmbo, 2) = LJ
        iAmbo = iAmbo + 1
        cAmbos = aAmbi(LJ, LI)
        aAmbi(LI, LJ) = iAmbo
    Next LJ
Next LI
'
'Esaminiamo gli ambo in Archivio:
For LI = LBound(wArr) To UBound(wArr) - 1
    For LJ = 5 To 8
        For LK = LJ + 1 To 9
        'e ognuno lo posizionamo al suo posto:
            If wArr(LI, LJ) > wArr(LI, LK) Then
                oInd = aAmbi(wArr(LI, LK), wArr(LI, LJ))
                aAmbi(wArr(LI, LK), wArr(LI, LJ)) = aAmbi(wArr(LI, LK), wArr(LI, LJ)) + 1
            Else
                oInd = aAmbi(wArr(LI, LJ), wArr(LI, LK))
                aAmbi(wArr(LI, LJ), wArr(LI, LK)) = aAmbi(wArr(LI, LJ), wArr(LI, LK)) + 1
            End If
            For LL = 1 To 10
                oArr(oInd, LL) = wArr(LI, LL)
            Next LL
        Next LK
    Next LJ
Next LI
'Stampa i risultati:
PCSh.Range("A1").Resize(UBound(oArr), 10) = oArr
MsgBox ("Completato, sec: " & Format(Timer - myTim, "0.0"))
End Sub

Va messo in un modulo standard; come di consueto le istruzioni marcate <<< in testa sono da adattare.
Ho dovuto brigare per trovare un algoritmo soddisfacente, penso di esserci riuscito; ma i risultati tocca a te confermarli o smentirli.
Noterai subito che i risultati non sono colorati, visto che faccio le operazioni evitando al max di accedere ai dati sul foglio; se fossero invece necessari allora sappi che i tempi rischiano di aumentare drasticamente (forse 100 volte)

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 17155
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Trova 4005 Coppie Numeri In Archivio

Postdi ikwae » 19/10/20 10:50

Gentilissimo Anthony… Il tuo brigare per realizzare il lavoro che hai scritto è molto gradito e apprezzato ma purtroppo con tanta amarezza e, tanta :oops: , devo dire che la macro è poco "felice" di colore.
Aggiungo che la macro è super velocissima è molto precisa ma aimè rende inutilizzabili le macro dei precedenti aiuti e quello dell’aiuto che devo chiedere (generatore integrale del colore) di conseguenza non utilizzabile nel modo che è ho pensato.
Si può utilizzare così ma è “povera” restituisce dati parziali da quello che cerco e, come ho detto in altri post, preferisco i dati alla velocità.
Che poi la tua macro è quasi istantanea e come scrivi
Anthony47 ha scritto:... sappi che i tempi rischiano di aumentare drasticamente (forse 100 volte)

ma se la macro è velocissima e moltiplicata per 100 è molto meno di 8 ore, circa, della mia “casareccia”.
Quindi se puoi dare “colore” alla macro sarei contento. Ringraziandoti per il lavoro fatto fino adesso. Cordialmente ikwae
*****
La settimana scorsa, nella Rubrica “I VOSTRI LAVORI”, ho letto di accodare i dati al post ma, non trovando né il tasto “accoda” né il tasto “nuovo TOPIC”, ho cliccato sul tasto “RISPONDI” è ho lasciato il post. Cliccando sul tasto "RISPONDI" spero di non avere fatto guai.
Excel 2007
Avatar utente
ikwae
Utente Senior
 
Post: 192
Iscritto il: 27/12/17 23:14

Re: Trova 4005 Coppie Numeri In Archivio

Postdi Anthony47 » 19/10/20 22:52

Temevo che la perdita di colore fosse un handicap, mi sembra esagerato invece che il colore sia l'informazione prevalente.

Comunque questa e' una versione colorata; limita il rallentamento a circa 25 volte.
Codice: Seleziona tutto
Sub BuonAzione233()
Dim oArr(), wArr, oInd, RCol
Dim N1 As Long, N2 As Long, I As Long
Dim ASh As Worksheet, PCSh As Worksheet
Dim LI As Long, LJ As Long, LArr(1 To 10)
Dim mN1, mN2, myTim As Single
Dim aAmbi(1 To 90, 1 To 90) As Long, LK As Long, LL As Long
Dim iAmbo As Long, cAmbos As Long
'
Set ASh = Sheets("Archivio")            '<<< Il foglio coi dati
Set PCSh = Sheets("PCC_2")              '<<< Il foglio dei risultati
'
myTim = Timer
PCSh.Range("A:K").Clear
I = ASh.Cells(Rows.Count, "B").End(xlUp).Row
wArr = ASh.Range("B2").Resize(I, 10).Value
'
ReDim oArr(1 To (I * 10 + 4100), 1 To 10)
'
'Qualche informazione su quel che ci aspetta:
For LI = LBound(wArr) To UBound(wArr) - 1
    For LJ = 5 To 8
        For LK = LJ + 1 To 9
        If wArr(LI, LJ) = 90 And wArr(LI, LK) = 90 Then Stop
            aAmbi(wArr(LI, LJ), wArr(LI, LK)) = aAmbi(wArr(LI, LJ), wArr(LI, LK)) + 1
            aAmbi(wArr(LI, LK), wArr(LI, LJ)) = aAmbi(wArr(LI, LK), wArr(LI, LJ)) + 1
        Next LK
    Next LJ
Next LI
'Crea i pointers:
cAmbos = 1
For LI = 1 To 89
    For LJ = LI + 1 To 90
        iAmbo = iAmbo + 0 + cAmbos
        oArr(iAmbo, 1) = LI: oArr(iAmbo, 2) = LJ
        iAmbo = iAmbo + 1
        cAmbos = aAmbi(LJ, LI)
        aAmbi(LI, LJ) = iAmbo
    Next LJ
Next LI
'
'Esaminiamo gli ambo in Archivio:
For LI = LBound(wArr) To UBound(wArr) - 1
    For LJ = 5 To 8
        For LK = LJ + 1 To 9
        'e ognuno lo posizionamo al suo posto:
            If wArr(LI, LJ) > wArr(LI, LK) Then
                oInd = aAmbi(wArr(LI, LK), wArr(LI, LJ))
                aAmbi(wArr(LI, LK), wArr(LI, LJ)) = aAmbi(wArr(LI, LK), wArr(LI, LJ)) + 1
            Else
                oInd = aAmbi(wArr(LI, LJ), wArr(LI, LK))
                aAmbi(wArr(LI, LJ), wArr(LI, LK)) = aAmbi(wArr(LI, LJ), wArr(LI, LK)) + 1
            End If
            For LL = 1 To 10
                oArr(oInd, LL) = wArr(LI, LL)
            Next LL
'            oArr(oInd, LL) = LI
        Next LK
    Next LJ
Next LI
'Stampa i risultati:
PCSh.Range("A1").Resize(UBound(oArr), 10) = oArr
Debug.Print "Copiati dati(4)", Format(Timer - myTim, "0.0")
DoEvents: DoEvents: DoEvents
'Applica formati:
Application.ScreenUpdating = False
For I = 1 To PCSh.Cells(Rows.Count, 1).End(xlUp).Row
If oArr(I, 3) > 0 Then
    PCSh.Cells(I, 4).Interior.Color = ASh.Range("B2").Cells(oArr(I, 1), 4).Interior.Color
    PCSh.Cells(I, 4).Font.ColorIndex = ASh.Range("B2").Cells(oArr(I, 1), 4).Font.ColorIndex
    PCSh.Cells(I, 10).Interior.Color = ASh.Range("B2").Cells(oArr(I, 1), 10).Interior.Color
    PCSh.Cells(I, 10).Font.ColorIndex = ASh.Range("B2").Cells(oArr(I, 1), 10).Font.ColorIndex
    RCol = ASh.Range("B2").Cells(oArr(I, 1), 5).Resize(1, 5).Interior.Color
    If RCol = 0 Then
        For LJ = 5 To 9
            PCSh.Cells(I, LJ).Interior.Color = ASh.Range("B2").Cells(oArr(I, 1), LJ).Interior.Color
            PCSh.Cells(I, LJ).Font.ColorIndex = ASh.Range("B2").Cells(oArr(I, 1), LJ).Font.ColorIndex
        Next LJ
    Else
            PCSh.Cells(I, 5).Resize(1, 5).Interior.Color = RCol
            PCSh.Cells(I, 5).Resize(1, 5).Font.ColorIndex = ASh.Range("B2").Cells(oArr(I, 1), 5).Font.ColorIndex
    End If
End If
If I Mod 5000 = 0 Then Debug.Print I, Format(Timer - myTim, "0.0"): DoEvents
Next I
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox ("Completato, sec: " & Format(Timer - myTim, "0.0"))
End Sub

Noterai che l'approccio rimane lo stesso per quanto riguarda il caricamento dei risultati, cui segue poi una fase di applicazione del colore. Rimaniamo ben sotto un'ora di elaborazione...
Buon collaudo

Si, ho notato il tuo contributo ma non ho ancora avuto tempo di esaminarlo e di spostarlo come discussione a sè stante con link sulla pagina de I Vostri lavori. Mi prometto di farlo a breve.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 17155
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Trova 4005 Coppie Numeri In Archivio

Postdi ikwae » 20/10/20 01:41

Anthony47 ha scritto:..... Rimaniamo ben sotto un'ora di elaborazione...

Gentilissimo Anthony … Mi hai spaventato mi è quasi venuto un colpo … Pensando a un’oretta di elaborazione ho deciso di andare a fare il caffè in cucina e ho mandato in esecuzione la macro e mi sono alzato spegnendo la luce e ho visto Excel lampeggiare pensando a un errore invece aveva già finito di fare i calcoli. Verificata a confronto con il foglio Fine sembra che tutti i valori sono unanime… Quindi la nuova macro, modificata per il colore, è quasi uguale alla precedente con tempi di una manciata di secondi in più, ma non oltre.

Adesso capisco il tuo “brigare” perché una macro così complessa (la 1à macro) e poi con l’aggiunta, nella 2à macro, di altro codice per la stampa dei risultati è diventata veramente una cosa stupenda e studiata in ogni dettaglio per non perdere velocità quindi immagino a quanto lavoro e impegno c’è dietro per avere dei risultati così stupefacenti. Adesso tocca a me studiare e per “sezionarla” tutta, per capire la struttura, impiegherò sei mesi e oltre e non è detto che capirò tutto.

Ti chiedo, se possibile, un semplicissimo ritocco, come ho accennato al mio primo post te lo chiedo, ma con tantissima vergogna e dispiacere, dopo il lavoro che hai fatto e la relativa modifica per il colore, si tratta di intercettare e copiare solo una stringa e incollarla sul foglio Posa_Coppia tutto qua. Non l’ho detto prima perché ho pensato che le coppie dei numeri si potessero mettere in matrice mentre invece con la stringa poteva essere più complesso dato che adesso c’è la macro penso che è più facile fare un ritocco.

Si tratta di una semplice stringa in testa ad ogni gruppo di numeri, sempre in colonna O, quando si trova si copia sul foglio Posa_Coppia sempre accodandola a partire dalla A1. Mentre per i numeri non cambia nulla seguire come è stato fatto fino adesso.

Ti rimando un allegato come prima con le stesse indicazioni un file con tre fogli; Archivio, Posa_Coppie e il foglio Fine_1.
Il foglio Fine_1 ha pochissime righe rispetto al precedente foglio Fine.

Per i ringraziamenti cosa dire grazie e grazie di cuore. Cordialmente ikwae
http://www.filedropper.com/trova4005cop ... hiviorete2
Excel 2007
Avatar utente
ikwae
Utente Senior
 
Post: 192
Iscritto il: 27/12/17 23:14


Torna a Applicazioni Office Windows


Topic correlati a "Trova 4005 Coppie Numeri In Archivio":


Chi c’è in linea

Visitano il forum: Nessuno e 18 ospiti