Conversione Da Sestine In Quartine

[ikwae]

Ciao a tutti e una buona giornata... sono ancora qui a chiedere il vostro aiuto per convertire un archivio di 6 colonne in quartine con il valore ... L’archivio ha il range G2:L(end) mentre il range delle quartine Q2:T(end) e in U2:U(end) i valori... dato l’alto numero di righe dell’archivio, se possibile,una macro veloce è molto gradita altrimenti prendo quello che arriva ... In allegato un foglio per le prove...Ringraziando anticipatamente 73 ikwae

http://www.filedropper.com/helparchivio6colonneaqne

[Anthony47]

Che cosa e' una quartina con il valore???

[ikwae]

Gentilissimo Anthony... grazie per la risposta ... una quartina con i valori non è altro che la somma di ogni quartina ripetuta ... Mi spiego meglio prima si trasformano le sestine in quartine e poi se ci sono quartine doppie,triple o maggiori di tre si cancellano le quartine ripetute e a dx (range U2:Uend) di ogni quartina si scrive la somma che ogni quartina è stata ripetuta.... spero di aver fatto "luce" e di non aver confuso le idee maggiormente... oppure trasforma le sestine, se è più semplice, in quartine per le ripetizioni dei doppioni mi arrangio io... Cordialmente ikwae

[Anthony47]

Prima di girare in tondo con una ulteriore domanda ti dico la mia interpretazione cosi' facciamo prima…

Dato l'elenco nelle colonne G:L, per ognuna delle righe vorresti calcolare quali quaterne possono essere realizzate (15 per ogni riga di 6 numeri), poi riepilogare per ognuna delle quaterne realizzabili quante volte quella quaterna si e' realizzata.

Se questo e' il quesito allora prova con questa macro:

Codice: Seleziona tutto

Sub Studio51()
Dim I As Long, J As Long, K As Long, L As Long
Dim qDic As Object, myK As String, eArr
Dim SSep As String, LastG As Long, LLB As Long, IA As Long
Dim kCnt As Long, kArr, oArr(), LB0 As Long
Dim UB1 As Long, vOff As Long, oCnt As Long, eAw As Long
'
'crea Q Dict
Set qDic = CreateObject("scripting.dictionary")
SSep = "-"
'
LastG = Cells(Rows.Count, "G").End(xlUp).Row
eArr = Cells(2, "G").Resize(LastG - 1, 6).Value
LLB = 3
mytim = Timer
For IA = 1 To UBound(eArr)
    'Sort estrazione:
    For I = 1 To 5
        For J = I + 1 To 6
            If eArr(IA, J) < eArr(IA, I) Then
                eAw = eArr(IA, I)
                eArr(IA, I) = eArr(IA, J)
                eArr(IA, J) = eAw
            End If
        Next J
    Next I
    'Calcola e conta le quaterne:
    For I = 1 To LLB
        For J = I + 1 To LLB + 1
            For K = J + 1 To LLB + 2
                For L = K + 1 To LLB + 3
                    myK = eArr(IA, I) & SSep & eArr(IA, J) & SSep & eArr(IA, K) & SSep & eArr(IA, L)
                    If qDic.exists(myK) Then
                        qDic.Item(myK) = qDic.Item(myK) + 1
                    Else
                        qDic.Add myK, 1
                        kCnt = kCnt + 1
                    End If
                Next L
            Next K
        Next J
    Next I
'    DoEvents
oCnt = oCnt + 1
If oCnt = 10000 Then
'traccia i tempi:
    Debug.Print IA, Format(Timer - mytim, "0.0")
    oCnt = 0
    DoEvents
End If
Next IA
'Prepara e incolla il risultato:
kArr = qDic.Keys
LB0 = LBound(kArr)
Range("Q2").Resize(800100, 12).ClearContents
If UBound(kArr) > 800000 Then UB1 = 800010 Else UB1 = UBound(kArr)
ReDim oArr(LB0 To UB1, 1 To 2)
For I = LB0 To UBound(kArr)
    oArr(LB0 + oCnt, 1) = kArr(I)
    oArr(LB0 + oCnt, 2) = qDic.Item(kArr(I))
    oCnt = oCnt + 1
    If oCnt > 800000 Then
        Range("Q2").Offset(0, vOff).Resize(oCnt + 2, 2).Value = oArr
        vOff = vOff + 3
        oCnt = 0
        Erase oArr
        ReDim oArr(LB0 To UB1, 1 To 2)
    End If
Next I
If oCnt > 0 Then
    Range("Q2").Offset(0, vOff).Resize(oCnt + 2, 2).Value = oArr
End If
End Sub

Tieni presente che essa richiede parecchi minuti per completarsi, e riporta nelle colonne da Q in avanti le quaterne e i valori

Se il quesito era un altro allora e' stato un inutile esercizio…

Ciao

[ikwae]

Gentilissimo Anthony... Ho fatto girare la tua macro ma scrive delle cose non volute ...

Dato l'elenco nelle colonne G:L, per ognuna delle righe vorresti calcolare quali quaterne possono essere realizzate (15 per ogni riga di 6 numeri), poi riepilogare per ognuna delle quaterne realizzabili quante volte quella quaterna si e' realizzata.

la tua prefazione è giusta ma il risultato non è quello sperato perché ho riscontrato cose diverse dalla tua prefazione e dalla mia richiesta:

1) la macro scrive due blocchi distinti di quartine e nello specifico:
-1a) in colonna Q (unica cella) i 4 numeri spaziati da trattini e nella colonna R i valori della quartine di Q
-1b) in colonna T (unica cella) i 4 numeri spaziati da trattini e nella colonna U i valori della quartine di T
-la colonna S è vuota
2) dopo il primo avvio, dal secondo in avanti, il primo blocco lo scrive a partire dalla riga 5362

3)Ho tentato di diminuire l’archivio a sole 28 righe per fare delle eventuali “modifiche” ma esce l’errore

Codice: Seleziona tutto

ReDim oArr(LB0 To UB1, 1 To 2)
For I = LB0 To UBound(kArr)
    oArr(LB0 + oCnt, 1) = kArr(I) 'ERROREEEEEEEEEEEEEEEEEEEEEEEE
    oArr(LB0 + oCnt, 2) = qDic.Item(kArr(I))
    oCnt = oCnt + 1
    If oCnt > 800000 Then

4) Probabilmente la macro è lenta perché deve scrivere due blocchi di quartine con i trattini io proporrei per velocizzarla un attimo di scrivere solo le quartine
nel range Q2:T(end) una cella per ogni numero e, i valori non metterli mi arrangio io..

Mi dispiace per quello che scrivi che è stato un “inutile esercizio” ma non so proprio da dove sono arrivati i blocchi e i trattini ... Naturalmente un doppio grazie per il lavoro fatto e del tempo che mi hai dedicato ...cordialmente ikwae

[Anthony47]

La macro calcola 1292000 combinazioni, metterle in due blocchi e' obbligatorio visto che Excel non ha tutte queste righe.
Calcolare le quartine col trattino tra i numeri e' un modo per velocizzare la macro…
Nelle mie prove i risultati vengono sempre scritti da Q2 e T2 in avanti, mentre in colonna R e U vengono conteggiate 1800mila quaterne, come ci si aspetta da 120mila sestine; ma potrebbe andare in crisi per elenchi brevi, quindi ho inserito un oCnt = 0 in fase di "Prepara e incolla il risultato"
Il file e' scaricabile qui:
https://www.dropbox.com/s/xyii9j5geqyzj ... .xlsm?dl=0

Nel file ho inserito anche una seconda versione di codice che dovrebbe essere leggermente piu' veloce, ma senza cambiamenti sconvolgenti:

Codice: Seleziona tutto

Sub Studio52()
Dim I As Long, J As Long, K As Long, L As Long
Dim qDic As Object, myK As String, eArr
Dim SSep As String, LastG As Long, LLB As Long, IA As Long
Dim kCnt As Long, kArr(), oArr(), LB0 As Long
Dim UB1 As Long, vOff As Long, oCnt As Long, eAw As Long
Dim bCnt As Long
'
'crea Q Dict
Set qDic = CreateObject("scripting.dictionary")
SSep = "-"
'
LastG = Cells(Rows.Count, "G").End(xlUp).Row
eArr = Cells(2, "G").Resize(LastG - 1, 6).Value
ReDim kArr(1 To (UBound(eArr) + 2) * 15, 1 To 2)
LLB = 3
mytim = Timer
'Scan estrazioni:
For IA = 1 To UBound(eArr)
    'Sort estrazione (riga):
    For I = 1 To 5
        For J = I + 1 To 6
            If eArr(IA, J) < eArr(IA, I) Then
                eAw = eArr(IA, I)
                eArr(IA, I) = eArr(IA, J)
                eArr(IA, J) = eAw
            End If
        Next J
    Next I
    'Calcola e conta le quaterne:
    For I = 1 To LLB
        For J = I + 1 To LLB + 1
            For K = J + 1 To LLB + 2
                For L = K + 1 To LLB + 3
                    myK = eArr(IA, I) & SSep & eArr(IA, J) & SSep & eArr(IA, K) & SSep & eArr(IA, L)
                    If Not qDic.exists(myK) Then
                        kCnt = kCnt + 1
                        qDic.Add myK, kCnt
                        kArr(kCnt, 1) = myK
                    End If
                    kArr(qDic.Item(myK), 2) = kArr(qDic.Item(myK), 2) + 1
                Next L
            Next K
        Next J
    Next I
'    DoEvents
oCnt = oCnt + 1
If oCnt = 10000 Then
'traccia i tempi:
    Debug.Print IA, Format(Timer - mytim, "0.0")
    oCnt = 0
    DoEvents
End If
Next IA
'Prepara e incolla il risultato:
Range("Q2").Resize(1000100, 12).ClearContents
If kCnt > 1000000 Then UB1 = 1000000 Else UB1 = kCnt
'Primo blocco:
Range("Q2").Resize(UB1, 2) = kArr
'blocchi successivi:
Do
    bCnt = bCnt + 1
    If (bCnt * UB1) >= kCnt Then Exit Do
    If kCnt > (bCnt * UB1) Then
        ReDim oArr(1 To 1000000, 1 To 2)
        For I = LBound(oArr, 1) To UBound(oArr, 1)
            If (I + bCnt * UB1) > kCnt Then Exit For
            oArr(I, 1) = kArr(I + bCnt * UB1, 1)
            oArr(I, 2) = kArr(I + bCnt * UB1, 2)
        Next I
        Range("Q2").Offset(0, bCnt * 3).Resize(UB1, 2) = oArr
    Else
        Exit Do
    End If
DoEvents
Loop
MsgBox ("Completato in (sec): " & Format(Timer - mytim, "0.0"))
End Sub


Anche questa restituisce le quaterne con i numeri separati da "trattino"

Ciao

[ikwae]

Ciao Anthony... sono profondamente desolato e mortificato per il lavoro che hai fatto ma con i trattini non riesco a fare ulteriori lavorazioni quindi preferisco ridurre l'archivio e fare le ulteriori elaborazioni in due volte ma se possibile i trattini non ci devono essere un numero in ogni cella ... se è possibile modificare la macro in tal senso sarei contento. ancora tante scuse per una misera operazione ti ha fatto perdere del prezioso tempo e ripeto sono tanto mortificato ... allego un file con l'archivio ridotto(60 mila righe) per eventuale prove ... ringraziandoti doppiamente per l'aiuto e la tua Santa Pazienza ...cordialmente ikwae
http://www.filedropper.com/helparchivio ... b81203drop

[Anthony47]

Non abbatterti ne' mortificarti, il lavoro non va perso...

Ho mantenuto quasi totralmente il codice della Sub Studio52, ma ho invertito la posizione tra Quartina e Conteggio; in questo modo posso fare "Test-in-Colonna" sulle quartine separate col trattino per ottenere gli elenchi con ogni numero in una cella.
Il nuovo codice della macro:

Codice: Seleziona tutto

Sub Studio52()
Dim I As Long, J As Long, K As Long, L As Long
Dim qDic As Object, myK As String, eArr
Dim SSep As String, LastG As Long, LLB As Long, IA As Long
Dim kCnt As Long, kArr(), oArr(), LB0 As Long
Dim UB1 As Long, vOff As Long, oCnt As Long, eAw As Long
Dim bCnt As Long, MaBlock As Long
'
'crea Q Dict
Set qDic = CreateObject("scripting.dictionary")
SSep = "-"
'
LastG = Cells(Rows.Count, "G").End(xlUp).Row
eArr = Cells(2, "G").Resize(LastG - 1, 6).Value
ReDim kArr(1 To (UBound(eArr) + 2) * 15, 1 To 2)
LLB = 3
mytim = Timer
'Scan estrazioni:
For IA = 1 To UBound(eArr)
    'Sort estrazione (riga):
    For I = 1 To 5
        For J = I + 1 To 6
            If eArr(IA, J) < eArr(IA, I) Then
                eAw = eArr(IA, I)
                eArr(IA, I) = eArr(IA, J)
                eArr(IA, J) = eAw
            End If
        Next J
    Next I
    'Calcola e conta le quaterne:
    For I = 1 To LLB
        For J = I + 1 To LLB + 1
            For K = J + 1 To LLB + 2
                For L = K + 1 To LLB + 3
                    myK = eArr(IA, I) & SSep & eArr(IA, J) & SSep & eArr(IA, K) & SSep & eArr(IA, L)
                    If Not qDic.exists(myK) Then
                        kCnt = kCnt + 1
                        qDic.Add myK, kCnt
                        kArr(kCnt, 2) = myK
                        kArr(kCnt, 1) = 1
                    Else
                        kArr(qDic.Item(myK), 1) = kArr(qDic.Item(myK), 1) + 1
                    End If

                Next L
            Next K
        Next J
    Next I
'    DoEvents
oCnt = oCnt + 1
If oCnt = 10000 Then
'traccia i tempi:
    Debug.Print IA, Format(Timer - mytim, "0.0")
    oCnt = 0
    DoEvents
End If
Next IA
'Prepara e incolla il risultato:
Range("Q1").Resize(1000100, 24).ClearContents            '**1
MaBlock = 1000000                               'Block size, rows
If kCnt > MaBlock Then UB1 = MaBlock Else UB1 = kCnt
'Primo blocco:
Range("Q2").Resize(UB1, 2) = kArr
Range("Q2").Offset(0, 1).Select                         'Text to Column
Call T2Col
'blocchi successivi:
Do
    bCnt = bCnt + 1
    If (bCnt * UB1) >= kCnt Then Exit Do
    If kCnt > (bCnt * UB1) Then
        ReDim oArr(1 To MaBlock, 1 To 2)
        For I = LBound(oArr, 1) To UBound(oArr, 1)
            If (I + bCnt * UB1) > kCnt Then Exit For
            oArr(I, 1) = kArr(I + bCnt * UB1, 1)
            oArr(I, 2) = kArr(I + bCnt * UB1, 2)
        Next I
        Range("Q2").Offset(0, bCnt * 6).Resize(UB1, 2) = oArr
        Range("Q2").Offset(0, bCnt * 6 + 1).Select        'Text to Column
        Call T2Col
    Else
        Exit Do
    End If
DoEvents
Loop
MsgBox ("Completato in (sec): " & Format(Timer - mytim, "0.0"))
End Sub


Testo-in-Colonne e' fatta con

Codice: Seleziona tutto

Sub T2Col()
'
    Selection.EntireColumn.Select
    Selection.TextToColumns Destination:=Selection.Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    Range("R1").Select
End Sub


Ho anche provato un diverso modo di ordinare le sestine (vedi Sub Studio53 in Modulo4), ma ho ottenuto un lieve peggioramento..

Tutto e' contenuto nel file scaricabile al link gia' comunicato

Ciao

[ikwae]

ciao Anthony... ho scaricato il file e ho fatto girare la macro dopo aver commentato il messaggio e la macro ha lavorato e ha sviluppato 10 colonne Q:U mentre la colonna V rimane libera e altro gruppo di 5 colonne da W:AA ... non sapendo cosa prendere ho messo in ordine crescente Q:U (comanda la colonna U) e mi sono accorto che sulla colonna Q e sulla R ci sono vari 1 e 2 in entrambe le colonne sulla stessa riga ... Quindi di conseguenza l'ho fatto anche con W:AA e anche qui sulla colonna W e la X ci sono tanti 1 e 2 sulla stessa riga... altro non sapreri cosa dirti anzi ti dico che le colonne X:AA sono occupate dei terni(sul foglio reale che lavoro tutti i giorni ho dalle sestine agli ambi) quindi non si possono occupare .... Ma quella bella macro veloce che mi hai fatto per i terni con la MapT sul codice non si può applicare anche per le sestine?... mi auto mortifico ancora dato che ti faccio ulteriormente ritoccare la macro ... naturalmente tutto il tuo lavoro è molto gradito e super apprezzato cordialmente ikwae

[Anthony47]

Stavolta sono io che mi mortifico, perche' non ho capito proprio cosa hai cercato di dirmi…

La macro da eseguire si chiama Studio52, nella versione indicata al messaggio precedente
Come ti ho scritto, ho invertito le colonne Conteggio /Quartine, e' forse questo che ti mette in difficolta'?
In colonna Q c'e' il "conteggio", in colonne R:U ci sono le quartine; idem (se le quartine sono >1milione) in colonna W il conteggio e in colonne X:AA un secondo gruppo di quartine; idem (se le quartine fossero >2milioni) altro conteggio /quartine in colonne AC:AG.
Quanto al riferimento alla macro sui terni, bisogna ricordare che ci sono max 117mila terni, mentre le quaterne sono oltre 2.5milioni.

La macro azzera senza preavviso l'area Q:AN, vedi istruzione marcata **1; in realta' mi accorgo che basterebbe fermarsi a colonna AH, quindi (se cancellare tante colonne desse fastidio) puoi modificare la riga: non Resize(1000100, 24) ma Resize(1000100, 18)

Ciao

[ikwae]

Forse sarà l'ora tardi o la vecchiaia che avanza per non parlare di qualche punta di dell'Alzheimer che spunta ma non ho capito nulla ... e se devo far girare la macro Studio52 la Studio53 a cosa serve? .... domani qui e festa(Sant'Ambrogio) e con calma leggerò tutto per vedere cosa risponderti oppure riesco a far andare le tue macro ... per i terni non dare adito fai finta che non li hai letti altrimenti andremo alle Calende greche... buona notte e cordialmente ikwae

[Anthony47]

Stavolta sono io che mi mortifico, perche' non ho capito proprio cosa hai cercato di dirmi…

Forse sarà l'ora tardi o la vecchiaia che avanza per non parlare di qualche punta di dell'Alzheimer che spunta ma non ho capito nulla ...

Siamo messi bene, allora!

Comunque quello pubblicato e' il mio file di lavoro; contiene la vecchia Studio51, contiene Studio52 che e' la macro al momento "in pole position", contiene Studio53 che e' una variante di Studio52 (diverso criterio di ordinamento estrazione) ma alla fine meno performante. A parte che Studio53 non gira (senza togliere quella Exit Sub iniziale), comunque il suo output e' pari a Studio52: 1 colonna di conteggio, 4 colonne di quartine; altri blocchi analoghi nelle colonne successive se ci sono >1milione di quartine.

Buon obej obej

[ikwae]

Gentilissimo Anthony ... funziona tutto a meraviglia ... ho "accorciato" l'archivio a 75 mila righe(quindi non scrive nelle colonne occupate) e registrato una macro che copia la colonna Q(per capirci quella con i valori) e la incolla sulla colonna V... la stessa macro sposta a sx le 5 colonne così facendo salvo capre e cavoli... ma c'è un piccolo neo a metà procedimento della macro esce una scritta "sono presenti dati sostituirli?" come faccio a non farla comparire oppure dare un si in automatico per poterla farla proseguire? se si supera questo altro problemuccio penso che abbiamo finito ... cordialmente ikwae

[ikwae]

Gentilissimo Anthony... il neo l'ho risolto con Application.DisplayAlerts=False quindi funziona tutto... quindi non mi rimane che abbondare sui ringraziamenti del tuo lavoro, del tempo che mi hai dedicato e della tua Santa Pazienza ... un infinito Grazie e un infinito +1 grazie cordialmente ikwae

[Anthony47]

Bravo, hai fatto bene a "portarti avanti"…
Nel frattempo mi e' venuta la voglia di provare l'uso di una matrice a 4 dimensioni invece del Dictionary + Matrice a 2 dimensione; i risultati sono "molto buoni" in termine di tempo di esecuzione.

La penultima versione della macro e' quindi diventata:

Codice: Seleziona tutto

Sub Studio54()
Dim I As Long, J As Long, K As Long, L As Long, myTim As Single
Dim eArr, kCnt As Long, oArr(), BigArr() As Integer
Dim LastG As Long, LLB As Long, IA As Long
Dim oCnt As Long, eAw As Long
Dim bCnt As Long, MaBlock As Long, baCnt As Long
'
ReDim BigArr(1 To 90, 1 To 90, 1 To 90, 1 To 90)
MaBlock = 1000000                               'Block size, rows. >>> MAX 1milione

LastG = Cells(Rows.Count, "G").End(xlUp).Row
eArr = Cells(2, "G").Resize(LastG - 1, 6).Value
ReDim oArr(1 To MaBlock, 1 To 5)
LLB = 3
myTim = Timer
'Scan estrazioni:
For IA = 1 To UBound(eArr)
    'Sort estrazione (riga):
    For I = 1 To 5
        For J = I + 1 To 6
            If eArr(IA, J) < eArr(IA, I) Then
                eAw = eArr(IA, I)
                eArr(IA, I) = eArr(IA, J)
                eArr(IA, J) = eAw
            End If
        Next J
    Next I
    'Calcola e conta le quaterne:
    For I = 1 To LLB
        For J = I + 1 To LLB + 1
            For K = J + 1 To LLB + 2
                For L = K + 1 To LLB + 3
                BigArr(eArr(IA, I), eArr(IA, J), eArr(IA, K), eArr(IA, L)) = BigArr(eArr(IA, I), eArr(IA, J), eArr(IA, K), eArr(IA, L)) + 1
                kCnt = kCnt + 1
                Next L
            Next K
        Next J
    Next I
'    DoEvents
oCnt = oCnt + 1
If oCnt = 10000 Then
'traccia i tempi:
    Debug.Print IA, Format(Timer - myTim, "0.0"), kCnt
    oCnt = 0
    DoEvents
End If
Next IA
'Prepara e incolla il risultato:
For I = 1 To 87
    For J = I + 1 To 88
        For K = J + 1 To 89
            For L = K + 1 To 90
                baCnt = BigArr(I, J, K, L)
                If baCnt > 0 Then
                    oCnt = oCnt + 1
                    oArr(oCnt, 1) = I
                    oArr(oCnt, 2) = J
                    oArr(oCnt, 3) = K
                    oArr(oCnt, 4) = L
                    oArr(oCnt, 5) = baCnt
                    If oCnt >= MaBlock Then
                        'Incolla blocchi quando pronti
                        Debug.Print "Clearing " & Range("Q2").Offset(0, bCnt * 6).Resize(1001000, 7).Address
                        Range("Q2").Offset(0, bCnt * 6).Resize(1001000, 5).ClearContents          '**1
                        Debug.Print "Filling  " & Range("Q2").Offset(0, bCnt * 6).Resize(MaBlock, 5).Address, _
                           Format(Timer - myTim, "0.0")
                        Range("Q2").Offset(0, bCnt * 6).Resize(MaBlock, 5) = oArr
                        ReDim oArr(1 To MaBlock, 1 To 5)
                        oCnt = 0
                        bCnt = bCnt + 1
                    End If
                End If
            Next L
        Next K
    Next J
DoEvents
Next I
'Incolla ultimo blocco:
If oCnt > 0 Then
    Debug.Print "Clearing " & Range("Q2").Offset(0, bCnt * 6).Resize(1001000, 7).Address
    Range("Q2").Offset(0, bCnt * 6).Resize(1001000, 7).ClearContents          '**1
    Debug.Print "Filling  " & Range("Q2").Offset(0, bCnt * 6).Resize(1001000, 7).Address, _
       Format(Timer - myTim, "0.0")
    Range("Q2").Offset(0, bCnt * 6).Resize(oCnt, 5) = oArr
    ReDim oArr(1 To 1, 1 To 1)
End If
ReDim BigArr(1 To 1)

MsgBox ("Completato in (sec): " & Format(Timer - myTim, "0.0"))
End Sub


Il file presente su dropbox e' aggiornato con questa nuova versione, ma contiene anche le versioni precedenti.
La macro lavora (come nelle versioni precedenti) con blocchi di 1milione di quartine; se ce ne sono di piu' allora piu' blocchi di risultati saranno affiancati al primo blocco (quello che occupa Q:U). In ogni caso, accanto all'ultimo blocco scritto (o accanto all'unico blocco scritto) vengono cancellate due colonne in piu'; lo dico nel caso che a destra della colonna U tu abbia inserito formule o altri dati.

Ciao

[ikwae]

Gentilissimo Anthony... stupenda, magnifica e veloce ... tuttavia per non far scrivere dati, dopo la colonna U, ho accorciato l'archivio a vari livelli e il blocco delle quartine le scrive giuste ma sotto a partire dalla riga xx ... mi spiego meglio ho eliminato più volte parti di archivio accorciandolo e le quartine le scrive a partire dalla riga 4632 oppure dalla riga 5644 oppure alla riga 6824 oppure alla riga 8131 lo dico come riscontro e l'ho riscontrato sia copiando la macro del post e sia scaricando il file da Dropbox... Naturalmente un doppio grazie per il tuo lavoro e la tua attenzione cordialmente ikwae

[Anthony47]

Grrrr…
Nella Sub Studio54 mancava l'istruzione oCnt = 0 che gia' avevamo aggiunto in una fase precedente; va messa subito dopo la riga "Prepara e incolla il risultato"

Mi pare inoltre di capire che ti da' fastidio scrivere dopo la colonna U; per questo ho inserito, all'interno del blocco di istruzioni "Incolla blocchi quando pronti", questo controllo:

Codice: Seleziona tutto

'Gestisce max numero di blocchi:
                        If bCnt >= Range("O1").Value Then 'beep: Exit Sub
                            DoEvents
                            MsgBox ("Compilati N? " & bCnt & " blocchi in (sec): " & Format(Timer - myTim, "0.0"))
                            Exit Sub
                        End If


In questo modo si puo' scrivere in O1 il numero max di blocchi di 6 colonne (cinque di dati e una di separazione tra i blocchi) che si voglio scrivere; se O1 e' vuoto o contiene 1 allora si riempiranno solo le colonne Q:U, fino a un massimo di 1milione di righe

I file disponibile su dropbox e' ora allineato con quanto qui scritto; ripubblico il link:
https://www.dropbox.com/s/xyii9j5geqyzj ... .xlsm?dl=0

Ciao

[ikwae]

Ciao ... alcune volte mi viene in mente che le sbagli apposta per vedere se riesco a leggere e modificare le tue macro ... ci vuole ancora tempo il Miracolo deve ancora nascere .... anche se alcune macro li ho già dire modificate è una parola grossa mi limito a dire che dopo ore e ore di prove qualche cosa riesco a capire ma è solo fortuna ...

Mi pare inoltre di capire che ti da' fastidio scrivere dopo la colonna U;

vorrei fare chiarezza in un foglio chiamato "Ponte" ho l'archivio a 5 colonne e "sopra" un archivio a 6 colonne (si usa l'uno o l'altro) e due colonna dopo ho l'archivio a 4 colonne e dopo 2 colonne ho l'archivio a tre colonne e dopo 2 colonne ho l'archivio degli ambi ossia e 2 colonne ... lo so che per tanti è irreale ma io metto al posto dell'archivio a 5 colonne cinquine super qualificate e poi lancio la "filiera" delle macro che da 5 va a 4 a 3 e per finire ambi .. a cosa serve tutto questo? a prendere nelle mie "prese" per la formazione di cinquine o sestine per poi confrontarli con i dati reali ... quindi occupare le colonne a dx o sx vuol dire "smantellare" un qualche cosa che già preparato e funzionante con dei range prestabiliti ... ringraziandoti per il tuo Grrrrrr(vuol dire che vuoi le cose giuste e a posto e che devono andare in un determinato modo) ... dire del caffè è scrivere ormai perdendo tempo ma è sempre valido ... cordialmente ikwae