You are here:---Rispondi a: [RISOLTO] Quaterne
Rispondi a: [RISOLTO] Quaterne2018-05-18T21:39:41+02:00

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

sidsid
Moderatore
    Post totali: 718

    Spero che il tuo pc sia più performante del mio
    Ti passo i codici: una macro e una UDF; entrambi da mettere nello stesso modulo standard.
    Questa la macro:

    Sub VERIFICA_QUATERNE()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim vArchivio As Variant, vQuaterne As Variant, vFinale() As Variant, vQuaterna As Variant, v As Variant
    Dim nRighe As Integer, nCicli As Integer, nColRif As Integer, n As Integer, nPartenza As Integer, nArrivo  As Integer
    Dim j As Long, jj As Long, nRigaRif As Long
    
    Dim t As Date
    
    Set ws1 = Sheets("Esiti")
    Set ws2 = Sheets("Archivio_Q_1")
    vQuaterne = ws1.Range("AB18:AB149012")
    nRighe = ws1.Range("AA3")
    nCicli = ws1.Range("AB3")
    nColRif = 28 'colonna "AB"
    nRigaRif = 18 'prima riga del range di destinazione
    t = Time
    
    ReDim vFinale(1 To UBound(vQuaterne), 1 To nCicli)
    
    nPartenza = ws1.Range("AD3")
    nArrivo = nPartenza + nRighe - 1
    
    'ciclo che spazzola le quaterne in AB
    For j = LBound(vQuaterne) To UBound(vQuaterne)
          
        'questo loop viene eseguito per le volte della cella AB3 (cicli)
        For n = 1 To nCicli
    
            'trasformo la stringa della quaterna in un array
            vQuaterna = Split(vQuaterne(j, 1), "_")
            
            'range del ciclo n in cui fare la ricerca della quaterna
            vArchivio = ws2.Range("C" & nPartenza & ":V" & nArrivo)
            
            'ciclo le righe del range
            For jj = LBound(vArchivio, 1) To UBound(vArchivio, 1)
                
                'riga jj del range ciclato
                v = Application.WorksheetFunction.Index(vArchivio, jj, 0)
                
                'passo la quaterna ciclata e l'archivio di ricerca alla udf
                If VERIFICA(v, vQuaterna) Then
                    vFinale(j, n) = vFinale(j, n) + 1
                End If
            
            Next jj
            'incremento le variabili
            nPartenza = nArrivo + 1
            nArrivo = nArrivo + nRighe
        
        Next n
        'riporto le variabili al valore iniziale
        nPartenza = ws1.Range("AD3")
        nArrivo = nPartenza + nRighe - 1
    Next j
    'pulisco il range di destinazione
    ws1.Range(ws1.Cells(nRigaRif, nColRif + 1), ws1.Cells(149012, nColRif + 10)).ClearContents
    
    'scarico la matrice nel range di destinazione
    ws1.Range(ws1.Cells(nRigaRif, nColRif + 1), ws1.Cells(nRigaRif + UBound(vQuaterne) - 1, nColRif + nCicli)).Value = vFinale
    
    MsgBox Format(Time - t, "HH:MM:SS"), vbInformation, "CODICE ESEGUITO IN....."
    
    Set ws1 = Nothing
    Set ws2 = Nothing
    
    End Sub

    Questa la udf

    Function VERIFICA(aMioArr, n) As Boolean
    Dim x As Variant
    On Error Resume Next
    For Each x In n
        If IsError(Application.WorksheetFunction.Match(CDbl(x), aMioArr, 0)) Then
            On Error GoTo 0
            Exit Function
        End If
    Next x
    On Error GoTo 0
    VERIFICA = True
    End Function

    Fai molti test; segnala tutto quello che non va; 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