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: 309
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: 19196
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: 309
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: 19196
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: 309
Iscritto il: 27/12/17 23:14

Re: Trova 4005 Coppie Numeri In Archivio

Postdi Anthony47 » 20/10/20 22:24

Hai rischiato grosso, perche' nella macro precedente io il contenuto di O:P non lo guardo proprio, l'elenco e' calcolato dalle combinazioni dei dati in archivio incasellandolo in sequenza per ogni coppia.
Quindi il "semplice ritocco" ha inizialmente fatto saltare tutto il lavoro.

Alla fine l'ho "tamponata" procedendo inizialmente sempre allo stesso modo (calcolo e incasellamento di tutti gli ambo creati dai dati in archivio) e aggiungendo una fase di filtro sulla base dell'elenco che metti in O:P. Poi si riprende come da vecchia macro: si scrivono i dati sul foglio e infine si applica la formattazione.
Ti anticipo che un ulteriore "piccola aggiunta" scombussolerebbe tutto...
Il nuovo codice macro:
Codice: Seleziona tutto
Sub BuonAzione666()
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
'
'Filtra per gli ambo desiderati:
Dim AWish, WACnt As Long, WHead As Long, WCat As Long
Dim OWArr(), OWInd As Long
AWish = Range(ASh.Range("O1"), ASh.Range("O1").End(xlDown).Offset(0, 1)).Value
'Crea inventario:
For LI = 1 To UBound(AWish)
    If AWish(LI, 2) <> "" Then
        WACnt = WACnt + aAmbi(AWish(LI, 2), AWish(LI, 1))
        WHead = WHead + 1
    Else
        WCat = WCat + 1
    End If
Next LI
'Sposta da OArr a OWArr:
ReDim OWArr(1 To (WACnt + WHead + WCat * 2), 1 To 10)
OWInd = 1
For LI = 1 To UBound(AWish)
    If AWish(LI, 2) = "" Then
        OWArr(OWInd, 1) = AWish(LI, 1)
        OWInd = OWInd + 1
    Else
        OWArr(OWInd, 1) = AWish(LI, 1)
        OWArr(OWInd, 2) = AWish(LI, 2)
        OWInd = OWInd + 1
        oInd = aAmbi(AWish(LI, 1), AWish(LI, 2)) - aAmbi(AWish(LI, 2), AWish(LI, 1))
        For LJ = oInd To oInd + aAmbi(AWish(LI, 2), AWish(LI, 1)) - 1
            For LK = 1 To 10
                OWArr(OWInd, LK) = oArr(oInd, LK)
            Next LK
            oInd = oInd + 1
            OWInd = OWInd + 1
        Next LJ
    End If
Next LI
'
'Stampa i risultati da OWArr:
PCSh.Range("A1").Resize(UBound(OWArr), 10) = OWArr
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 OWArr(I, 3) > 0 Then
    PCSh.Cells(I, 4).Interior.Color = ASh.Range("B2").Cells(OWArr(I, 1), 4).Interior.Color
    PCSh.Cells(I, 4).Font.ColorIndex = ASh.Range("B2").Cells(OWArr(I, 1), 4).Font.ColorIndex
    PCSh.Cells(I, 10).Interior.Color = ASh.Range("B2").Cells(OWArr(I, 1), 10).Interior.Color
    PCSh.Cells(I, 10).Font.ColorIndex = ASh.Range("B2").Cells(OWArr(I, 1), 10).Font.ColorIndex
    RCol = ASh.Range("B2").Cells(OWArr(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(OWArr(I, 1), LJ).Interior.Color
            PCSh.Cells(I, LJ).Font.ColorIndex = ASh.Range("B2").Cells(OWArr(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(OWArr(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

Questa stessa macro puo' essere usata in sostituzione di quella pubblicata ieri sera (Sub BuonAzione233), bisogna che l'elenco di colonne O:P parta da riga e; non e' obbligatorio che ci siano le separazioni "Categoria_xxx". Bisogna solo mettere in conto un utilizzo piu' elevato di memoria e magari un paio di secondi in piu' di tempo di esecuzione. Insomma sempre sotto un'ora di elaborazione...

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

Re: Trova 4005 Coppie Numeri In Archivio

Postdi ikwae » 21/10/20 02:36

Gentilissimo Anthony… Ho “collaudato” le tue magnifiche macro e ho cercato di verificare il funzionamento a vari livelli.

1) La Sub BuonAzione231() la 1à, è super veloce e trova in archivio tutte le coppie degli ambi ossia i famosi 4005 coppie. Indipendentemente da qualsiasi numero presenti o non presenti,nelle colonne O:P … Va per la sua strada…
Quindi destinata esclusivamente a quel tipo di funzione. E va benissimo almeno per me.

2) La Sub BuonAzione233() la 2à, è identica alla prima, modesta variazione in velocità ma porta oltre alle cinquine dell’archivio anche il colore. E va super benissimo anche questa e sono 2.

3) la Sub BuonAzione666() la 3à, se deve essere usata come la 1à o la 2à in testa ossia in O1 deve esseri scritto qualche cosa altrimenti trova in archivio la prima coppia presente in O:P e poi si ferma.
IO in O1 ha scritto Pippo (o altra stringa a piacere) e la macro è partita a razzo se sotto Pippo iniziano i famosi 4005 ambi. Scrive sul foglio destinazione Posa_Coppie la parola Pippo e poi sotto per 267.016 righe quello che ha trovato in archivio e i conteggi
sono giusti e precisi. Oppure se sotto la Parola Pippo ci sono coppie di numeri a piacere lì trova tutti in archivio e lì scrive sul foglio di destinazione Posa_Coppia sotto la stringa Pippo.

Ricapitolando se si vogliono trovare coppie di numeri in archivio si scrive in O1 la stringa Pippo e in O2:P(end) le coppie dei numeri da cercare poi si fa partire la macro e tutto quello che trova in archivio lo incolla sul foglio di destinazione Posa_Coppie.
E va benissimo anche questa e sono 3.

L’unico neo che ho trovato caricando le Categorie delle mie coppie che hanno i numeri invertiti ossia in colonna O il numero maggiore della coppia e a dx in colonna P il numero minore e da errore

Codice: Seleziona tutto
For LK = 1 To 10
          OWArr(OWInd, LK) = oArr(oInd, LK) <<<<<<<<< errore giallo solo questa riga
            Next LK
            oInd = oInd + 1

lo so che trovare in archivio 88 e 28 è lo stesso che trovare 28 e 88 purtroppo dato che vengono generati in un ciclo non sono in grado di andare a vedere cosa combina il programma e mi accorgo solo quando si blocca perché esce l’errore.
Anthony sicuramente non è mia intenzione scombussolare tutto ma se è una cosa semplice le la puoi modificare va bene altrimenti la tengo così e farò diversamente.
Ringraziandoti tantissimo per il lavoro svolto. Cordialmente ikwae
Excel 2007
Avatar utente
ikwae
Utente Senior
 
Post: 309
Iscritto il: 27/12/17 23:14

Re: Trova 4005 Coppie Numeri In Archivio

Postdi Anthony47 » 21/10/20 10:02

caricando le Categorie delle mie coppie che hanno i numeri invertiti ossia in colonna O il numero maggiore della coppia e a dx in colonna P il numero minore e da errore

Eh gia'...
Aggiungi in questa posizione le istruzioni marcate '+
Codice: Seleziona tutto
'Crea inventario:
For LI = 1 To UBound(AWish)
    If AWish(LI, 2) <> "" Then
        If AWish(LI, 1) > AWish(LI, 2) Then     '*
            cippa = AWish(LI, 2)                '+
            AWish(LI, 2) = AWish(LI, 1)         '+
            AWish(LI, 1) = cippa                '+
        End If                                  '+
        WACnt = WACnt + aAmbi(AWish(LI, 2), AWish(LI, 1))
        WHead = WHead + 1
    Else
        WCat = WCat + 1
    End If
Next LI
'Sposta da OArr a OWArr:
'...


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

Re: Trova 4005 Coppie Numeri In Archivio

Postdi ikwae » 21/10/20 13:07

Gentilissimo Anthony… adesso con la modifica che mi ha fatto è tutto a posto.

Quindi ricapitolando posso trovare le coppie dei numeri con l’id, il concorso, la data, la somma, la ruota, il colore e, con l’ultima modifica anche con le Categorie.

Per completare il “cerchio” servono 380 mila colori, diversi, per ogni ruota ne ho trovate, per adesso, solo 1 milione ma questa è un’altra storia…

Ringraziandoti mille e mille volte per il quadruplo lavoro che hai fatto. Ti ringrazio anche di cuore per la tua Santa Pazienza.
Cordialmente ikwae
Excel 2007
Avatar utente
ikwae
Utente Senior
 
Post: 309
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 41 ospiti