You are here:---Rispondi a: [RISOLTO] Quaterne
Rispondi a: [RISOLTO] Quaterne2018-05-15T12:08:14+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Quaterne Rispondi a: [RISOLTO] Quaterne

sidsid
Moderatore
    Post totali: 718

    Tra poko esco quindi provo a postare la soluzione per quello che ho capito.
    La macro è riferita al foglio Archivio_Q_1
    Ho inserito anche il controllo del tempo impiegato.
    Col mio pc che è un pò datato (intel celeron 2.5 GHx – 2 mb di ram) impiega circa 15 secondi per l’archivio di 202 righe.
    Questo il codice:

    Sub QUATERNE_Q_1()
    
    Dim X As Variant, vQuaterne() As Variant
    Dim j As Long, jj As Long, jjj As Long, jjjj As Long, nIncr As Long, nUltimaRiga As Long, xRiga As Long
    Dim ws1 As Worksheet
    Dim rTab As Range
    Dim nRiga As Integer, n As Integer, nPrimaRiga As Integer
    Dim ArQ1     'conta le righe dell'archivio
    Dim t As Date
    
    ArQ1 = [b1]  'conta le righe dell'archivio
    Set ws1 = Sheets("Archivio_Q_1")
    Set rTab = ws1.Range("C10:V" & ArQ1)
    nPrimaRiga = rTab.Row 'prima riga della tabella
    nUltimaRiga = rTab.Rows(rTab.Rows.Count).Row 'ultima riga della tabella
    xRiga = nPrimaRiga
    t = Time
    
    'dimensiono la matrice finale
    ReDim vQuaterne(1 To ArQ1, 1 To 4845)
    
    For nRiga = 1 To rTab.Rows.Count
        X = Application.Transpose(ws1.Range(ws1.Cells(nPrimaRiga, 3), ws1.Cells(nUltimaRiga, 22)).Value)
        For j = LBound(X) To UBound(X) - 3
            For jj = j + 1 To UBound(X) - 2
                 For jjj = jj + 1 To UBound(X) - 1
                    For jjjj = jjj + 1 To UBound(X)
                        nIncr = nIncr + 1
                        vQuaterne(nRiga, nIncr) = X(j, 1) & "_" & X(jj, 1) & "_" & X(jjj, 1) & "_" & X(jjjj, 1)
                    Next jjjj
                Next jjj
            Next jj
        Next j
        nPrimaRiga = nPrimaRiga + 1
        nIncr = 0
    Next nRiga
    ws1.Range("W" & xRiga & ":GEE" & nUltimaRiga).Value = vQuaterne
    MsgBox Format(Time - t, "HH:MM:SS"), vbInformation, "CODICE ESEGUITO IN....."
    
    Set rTab = Nothing
    Set ws1 = Nothing
    End Sub

    Logicamente è dinamico, quindi lavora sulle estrazioni dell’intero archivio anche aumentandole
    Fa sapere, ciao

    • Questa risposta è stata modificata 1 anno, 4 mesi fa da sid sid.

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi