Condividi:        

Calcolo 4005 ambi

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

Re: Calcolo 4005 ambi

Postdi Anthony47 » 18/07/18 14:03

Ho esaminato la richiesta, e non ho individuato un algoritmo di calcolo in grado di velocizzare drasticamente i calcoli del 2*1 oppure 3*1 / 3*2, a parte ciclare ripetutamente sulle tabelle.
Per quanto riguarda le ricerche 3*1 /3*2 ho immaginato che in Y1 (ma la cella puo' essere impostata nel codice) si scriva 1 oppure 2 per indicare la semplificazione da esaminare, poi si puo' usare questa macro:
Codice: Seleziona tutto
Sub TreX21()
Dim bDati As String, FlxX As String, lLine As Long
Dim eArr, tArr(1 To 117480, 1 To 3), wArr(1 To 117480, 1 To 4) As Long, oArr(1 To 117480, 1 To 4), olArr
Dim I As Long, J As Long, A1 As Long, A2 As Long, A3 As Long, myTim As Single
Dim tCnt As Long, olCnt As Long, cEstr As Long, my1OR2 As Long, cDel As Long

bDati = "D4"        '<<< L'origine dei dati
FlxX = "Y1"         '<<< Indicazione 3 * x; se <1 o >2 la macro termina subito

Range(Range("AE4"), Cells(Rows.Count, "AL").End(xlUp)).ClearContents
my1OR2 = Range(FlxX)
If my1OR2 <> 2 And my1OR2 <> 1 Then
    MsgBox ("Contenuto di " & FlxX & " errato (valori ok: 1 o 2)")
    Exit Sub
End If
eArr = Range(Range(bDati), Range(bDati).Offset(0, 19).End(xlDown)).Value
olArr = Application.WorksheetFunction.Index(eArr, 2, 0)
lLine = UBound(eArr, 1)
For A1 = 1 To 88
myTim = Timer
    For A2 = A1 + 1 To 89
        For A3 = A2 + 1 To 90
            tCnt = tCnt + 1
            tArr(tCnt, 1) = A1: tArr(tCnt, 2) = A2: tArr(tCnt, 3) = A3
            For I = 1 To lLine
                olCnt = 0
                For J = 1 To 20
                    cEstr = eArr(I, J)
                    If cEstr = A1 Then
                        olCnt = olCnt + 1
                    ElseIf cEstr = A2 Then
                        olCnt = olCnt + 1
                    ElseIf cEstr = A3 Then
                        olCnt = olCnt + 1
                    End If
                    If olCnt = my1OR2 Then Exit For
                Next J
'
                If olCnt = my1OR2 Then
                    wArr(tCnt, 1) = wArr(tCnt, 1) + 1
                    cDel = I - wArr(tCnt, 2)
                    wArr(tCnt, 2) = I
                    If cDel > wArr(tCnt, 3) And I < lLine Then wArr(tCnt, 3) = cDel
                End If
'DoEvents
            Next I
        Next A3
    Next A2
    Debug.Print A1, Format(Timer - myTim, "0.00")
    DoEvents
Next A1
'
'Calcola i parametri di ogni ambo:
For I = 1 To UBound(wArr)
    oArr(I, 1) = lLine - wArr(I, 2)
    oArr(I, 2) = wArr(I, 1)
    oArr(I, 4) = wArr(I, 3) - 1
    oArr(I, 3) = oArr(I, 1) - oArr(I, 4)
Next I
'Output
Range("AE4").Resize(UBound(tArr), 3) = tArr
Range("AI4").Resize(UBound(oArr), 4) = oArr
MsgBox ("Completato...")
End Sub
Le righe marcate <<< sono da personalizzare come da commento.

La durata della macro e' comunque nel range di molti minuti, comunque meno di quanto richiesto dalla Sub Terni3x2 inserita nel file pubblicato. I tempi di esecuzione possono essere dedotti guardando il contenuto della "finestra Immediata" (il log deve evolvere da 1, 2, 3... fino a 88).

Le versione 2*1 e' derivata da questa prima macro; non richiede l'uso della cella Y1 ed e' abbastanza rapida:
Codice: Seleziona tutto
Sub DueX1()
Dim bDati As String, FlxX As String, lLine As Long
Dim eArr, tArr(1 To 4005, 1 To 3), wArr(1 To 4005, 1 To 4) As Long, oArr(1 To 4005, 1 To 4)
Dim I As Long, J As Long, A1 As Long, A2 As Long, A3 As Long, myTim As Single
Dim tCnt As Long, olCnt As Long, cEstr As Long, my1OR2 As Long, cDel As Long

bDati = "D4"        '<<< L'origine dei dati

Range(Range("AE4"), Cells(Rows.Count, "AL").End(xlUp)).ClearContents
my1OR2 = 1
eArr = Range(Range(bDati), Range(bDati).Offset(0, 19).End(xlDown)).Value
lLine = UBound(eArr, 1)
'For A1 = 1 To 88
myTim = Timer
    For A2 = A1 + 1 To 89
        For A3 = A2 + 1 To 90
            tCnt = tCnt + 1
            tArr(tCnt, 1) = A2: tArr(tCnt, 2) = A3  ': tArr(tCnt, 3) = A3
            For I = 1 To lLine
                olCnt = 0
                For J = 1 To 20
                    cEstr = eArr(I, J)
                    If cEstr = A3 Then
                        olCnt = olCnt + 1
                    ElseIf cEstr = A2 Then
                        olCnt = olCnt + 1
'                    ElseIf cEstr = A3 Then
'                        olCnt = olCnt + 1
                    End If
                    If olCnt = my1OR2 Then Exit For
                Next J
'
                If olCnt = my1OR2 Then
                    wArr(tCnt, 1) = wArr(tCnt, 1) + 1
                    cDel = I - wArr(tCnt, 2)
                    wArr(tCnt, 2) = I
                    If cDel > wArr(tCnt, 3) And I < lLine Then wArr(tCnt, 3) = cDel
                End If
'DoEvents
            Next I
        Next A3
    Next A2
    Debug.Print A1, Format(Timer - myTim, "0.00")
    DoEvents
'Next A1
'
'Calcola i parametri di ogni ambo:
For I = 1 To UBound(wArr)
    oArr(I, 1) = lLine - wArr(I, 2)
    oArr(I, 2) = wArr(I, 1)
    oArr(I, 4) = wArr(I, 3) - 1
    oArr(I, 3) = oArr(I, 1) - oArr(I, 4)
Next I
'Output
Range("AE4").Resize(UBound(tArr), 3) = tArr
Range("AI4").Resize(UBound(oArr), 4) = oArr
MsgBox ("Completato...")
End Sub


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

Sponsor
 

Re: Calcolo 4005 ambi

Postdi Statix » 18/07/18 20:18

Ciao Anthony47,
provato le macro ,tutto ok, con i tempi ci siamo quasi,
per la 3x1 e 3x2 il tempo impiegato si aggira su 2 minuti,
speravo qualcosina in meno(visto la macro precedente dei terni in 8 secondi)
ti ringrazio tantissimo,

va bene ugualmente , si è risparmiato moltissimo sui tempi,
e sui consumi elettrici.
PS se ti viene qualche nuova idea sul algoritmico per ridurre ulteriormente i tempi di elaborazione,
è sempre accetto. ;) ;)
Statix
Windows 10,
Office 2013,
Statix
Utente Senior
 
Post: 1287
Iscritto il: 12/05/06 21:55
Località: Provincia di Caserta

Re: Calcolo 4005 ambi

Postdi Anthony47 » 19/07/18 20:41

Codice: Seleziona tutto
per la 3x1 e 3x2 il tempo impiegato si aggira su 2 minuti
Avevo fatto le prove su un subset di dati, sui dati complessivi mi aspettavo di peggio.

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

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "Calcolo 4005 ambi":


Chi c’è in linea

Visitano il forum: Nessuno e 55 ospiti