Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

continuare un calcolo su di altro foglio

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

continuare un calcolo su di altro foglio

Postdi romant » 29/01/19 21:59

Salve, sono nuovo di questo forum, saluto tutti.
Una premessa, è da poco tempo che mi sto cimentando nelle macro di Excel.

Il mio problema per cui chiedo aiuto è il seguente: ho una macro, che mi combina 50 numeri in cinquine tenendo conto di alcune condizioni pertanto scrive solo le combinazioni specifiche. Siccome la macro combina i numeri in orizzontale, quindi terminate le colonne del foglio si ferma dandomi l'errore.
Chiedo a voi se c'è una possibilità che le combinazioni, quindi senza fermare la routine, possano continuare nelle colonne dei fogli successivi. Ho provato di tutto ma senza risultati, ma ricordo che non sono un esperto e ho da poco iniziato. La macro è la seguente, se devo allegare il file ditemi come devo fare.

Codice: Seleziona tutto
Sub startSearch()
   
    If Range("C1") = "" Then
        MsgBox "Inserire in C1 il numero degli addendi desiderati" & vbCrLf & _
               "Se si vogliono tutte le soluzioni inserire 999"
        Exit Sub
    End If
    Range("D1:XFD25").ClearContents
    LR = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B1:B" & LR).Select
    If Not TypeOf Selection Is Range Then GoTo ErrXIT
    If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
    If Selection.Rows.Count < 3 Then GoTo ErrXIT
   
    Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _
        HaveRandomNegatives As Boolean
    StartTime = Now()
    MaxSoln = Selection.Cells(1).Value
    TargetVal = Selection.Cells(2).Value
    InArr = Application.WorksheetFunction.Transpose( _
        Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
    HaveRandomNegatives = checkRandomNegatives(InArr)
    If Not HaveRandomNegatives Then
    ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
                & vbNewLine _
            & "It may take a lot longer to search for matches." & vbNewLine _
            & "OK to continue else Cancel", vbOKCancel) = vbCancel Then
        Exit Sub
        End If
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
        LBound(InArr), 0, 0.00000001, _
        Rslt, "", ", "
   
        drow = 1: dcol = 4
'-----------------PARTE MODIFICATA--------------------->
    Dim NumRighe As Integer
    Dim mySheets As Worksheet
    NumRighe = 0
    For J = 0 To UBound(Rslt)
      If Range("C1") < 999 Then
        quanti = Len(Rslt(J)) - Len(Replace(Rslt(J), ",", "")) + 1
        If quanti > NumRighe Then NumRighe = quanti
        If quanti = Range("C1") Then
          arr0 = Split(Rslt(J), ",")
          For I = 0 To UBound(arr0)
            Cells(drow, dcol) = Cells(arr0(I) + 2, 2)
            drow = drow + 1
          Next
          dcol = dcol + 1
          drow = 1
        End If
    Else
        quanti = Len(Rslt(J)) - Len(Replace(Rslt(J), ",", "")) + 1
        If quanti > NumRighe Then NumRighe = quanti
        arr0 = Split(Rslt(J), ",")
        For I = 0 To UBound(arr0)
            Cells(drow, dcol) = Cells(arr0(I) + 2, 2)
            drow = drow + 1
        Next
        dcol = dcol + 1
        drow = 1
        For Each mySheets In Worksheets(5)
        mySheets.Select
        mySheets.Application.Run
        Next mySheets
    End If
    Next
    PariDispariFasce
'<-------------------------------------------------------
    Exit Sub
ErrXIT:
    MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
        & "The selection should be a single contiguous range in a single column." & vbNewLine _
        & "The first cell indicates the number of solutions wanted.  Specify zero for all." & vbNewLine _
        & "The 2nd cell is the target value." & vbNewLine _
        & "The rest of the cells are the values available for matching." & vbNewLine _
        & "The output is in the column adjacent to the one containing the input data."
    End Sub

Function RealEqual(A, B, Optional Epsilon As Double = 0.00000001)
    RealEqual = Abs(A - B) <= Epsilon
    End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
    If CurrRslt = "" Then ExtendRslt = NewVal _
    Else ExtendRslt = CurrRslt & Separator & NewVal
    End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
        ByVal HaveRandomNegatives As Boolean, _
        ByVal CurrIdx As Integer, _
        ByVal CurrTotal, ByVal Epsilon As Double, _
        ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
    Dim I As Integer
    For I = CurrIdx To UBound(InArr)
        If RealEqual(CurrTotal + InArr(I), TargetVal, Epsilon) Then
            Rslt(UBound(Rslt)) = ExtendRslt(CurrRslt, I, Separator)
           
            If MaxSoln = 0 Then
'
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
                End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(I) > TargetVal + Epsilon) Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _
                I + 1, _
                CurrTotal + InArr(I), Epsilon, Rslt(), _
                ExtendRslt(CurrRslt, I, Separator), _
                Separator
            If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
        Else
           
            End If
        Next I
    End Sub
Function ArrLen(Arr()) As Integer
    On Error Resume Next
    ArrLen = UBound(Arr) - LBound(Arr) + 1
    End Function
Function checkRandomNegatives(Arr) As Boolean
    Dim I As Long
    I = LBound(Arr)
    Do While Arr(I) < 0 And I < UBound(Arr): I = I + 1: Loop
    If I = UBound(Arr) Then Exit Function
    Do While Arr(I) >= 0 And I < UBound(Arr): I = I + 1: Loop
    checkRandomNegatives = Arr(I) < 0
End Function

Sub EliminaColonne()
Dim d As Integer
uc = Range("D1").End(xlToRight).Column
ur = 20
dacanc = Range("C2").Value
k = InStr(dacanc, "#")

If k > 0 Then
    If k = 1 Then                 '= #n, elimina solo dispari corrispondenti
        dacanc = Right(dacanc, 1) * 1
        For c = uc To 4 Step -1
            d = (Cells(20, c) - Int(Cells(20, c))) * 10
            If d = dacanc Then
                Columns(c).Delete Shift:=xlToLeft
            End If
        Next c
    ElseIf k = 2 Then                 '= n#, elimina solo pari corrispondenti
        dacanc = Left(dacanc, 1) * 1
        For c = uc To 4 Step -1
            If Int(Cells(20, c)) = dacanc Then
                Columns(c).Delete Shift:=xlToLeft
            End If
        Next c
    Else                                            ' altri casi non previsti
        MsgBox "Valori non previsti dalla routine. Elaborazione interrotta"
        Exit Sub
    End If
End If
For c = uc To 4 Step -1
    If Cells(20, c) = dacanc Then
        Columns(c).Delete Shift:=xlToLeft
    End If
Next c
End Sub

Sub PariDispariFasce()
If Range("D1") = "" Then Exit Sub
uc = Range("D1").End(xlToRight).Column
r1 = 20
For c = 4 To uc
    p = 0
    d = 0
    f1 = 0
    f2 = 0
    f3 = 0
    ur = Cells(1, c).End(xlDown).Row
    If ur = Rows.Count Then ur = 1
    For r = 1 To ur
        If Cells(r, c) Mod 2 = 0 Then
            p = p + 1
        Else
            d = d + 1
        End If
        Select Case Cells(r, c)
            Case Is <= 16
                f1 = f1 + 1
            Case Is <= 33
                f2 = f2 + 1
            Case Is <= 50
                f3 = f3 + 1
        End Select
       
    Next r
    Cells(r1, c) = p & "." & d
    Cells(r1 + 1, c) = f1 & "." & f2 & "." & f3
Next c
End Sub


Sub EliminaFasce()
uc = Range("D1").End(xlToRight).Column
ur = 20
dacanc = Range("C3").Value
For c = uc To 4 Step -1
    If Cells(21, c) = dacanc Then
        Columns(c).Delete Shift:=xlToLeft
    End If
Next c
End Sub


Grazie a chi vorrà aiutarmi.
Antonio
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Sponsor
 

Re: continuare un calcolo su di altro foglio

Postdi romant » 29/01/19 23:22

Allego il file se a qualcuno interessa
http://www.filedropper.com/programmaprova2foglio
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Re: continuare un calcolo su di altro foglio

Postdi Anthony47 » 30/01/19 02:23

Scusa, ma perche' invece di scrivere in Orizzontale non scrivi in Verticale, visto che di colonne ce ne sono 16mila ma di righe oltre 1 milione?

A spanne, per quello che si capisce senza rincitrullire tra i ricchi commenti, per scrivere in colonne U:Y dovrebbe bastare modificare, all'interno della Sub startSearch la riga Cells(drow, dcol) = Cells(arr0(I) + 2, 2) in
Codice: Seleziona tutto
            Cells(dcol - 2, 20 + drow) = Cells(arr0(I) + 2, 2)


Va anche modificato il clear iniziale del risultato; non Range("D1:XFD25").ClearContents ma
Codice: Seleziona tutto
    Range("U:Y").ClearContents


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

Re: continuare un calcolo su di altro foglio

Postdi romant » 30/01/19 15:45

Salve Anthony, hai ragione, ma è una macro che ho trovato ed adattata tra mille difficoltà perché non sono ancora in grado di costruirne così complesse, e chissà quando ci riuscirò.

Provo a fare i cambiamenti e ti faccio sapere. Comunque grazie dell'interessamento.
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Re: continuare un calcolo su di altro foglio

Postdi romant » 30/01/19 16:01

Volevo anche dire che se hai il tempo e la voglia di modificarla dall'orizzontale in verticale, tenendo la struttura delle combinazioni intatta, in quanto, come vedi sotto ogni combinazione c'è la condizione pari-dispari e quella delle formule che ho diviso in tre.
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Re: continuare un calcolo su di altro foglio

Postdi romant » 30/01/19 19:54

Ho apportato le modifiche proposte, le combinazioni vengono visualizzate e scritte in verticale, ma purtroppo però non vengono visualizzate e scritte la colonna pari-dispari, né la colonna delle fasce riferite ad ogni combinazione. Queste colonne servono per identificare ed eliminare quelle combinazioni che si vogliono eliminare attraverso i tasti X, attraverso le celle C2 pari-dispari e C3 fasce, per ridurre il numero totali delle colonne che devono essere evidenziate in A6 e A7
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Re: continuare un calcolo su di altro foglio

Postdi romant » 30/01/19 19:59

Sto provando a cambiare le colonne con le righe, ma mi da sempre errore… Come ho detto prima non sono una cima...
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Re: continuare un calcolo su di altro foglio

Postdi Anthony47 » 31/01/19 00:31

Mi spiace, non ho nessuna idea di a che cosa servano le tue macro e di come siano organizzati i dati.
A occhio sembra che parli di 50 numeri da combinare a gruppi di 5 con un vincolo di Somma.

Su questa base, ho modificato il file allegato a una una vecchia discussione (vedi viewtopic.php?f=26&t=98502&p=566311#p566311) per inserire la somma degli "addendi" delle combinazioni calcolate e subordinare la presentazione della combinazione a quella clausola.

Trovi il mio file qui: https://www.dropbox.com/s/sp0n7dxfibytv ... .xlsm?dl=0

Il file al momento e' impostato per combinare 50 numeri e combinarli a gruppi di 5.
Il vincolo di Somma va impostato in P2
Il calcolo si avvia col tasto Calcola Sviluppo; elenchi di 100mila righe vengono calcolati in meno di 1 secondo e visualizzati nelle colonne A:E

Se i numeri non sono 50 e i gruppi non sono da 5 allora bisogna modificare B1 e B2; B3 va lasciata vuota.

In M3 viene riportato quante combinazioni teoriche sono possibili con quelle impostazioni; certamente il vincolo della somma ridurra' drasticamente il numero di combinazioni calcolate.
Si tenga presente che se il risultato e' >1048mila (le righe di Excel) allora solo le prime 1048mila righe saranno visualizzate

Il controllo del vincolo della somma viene fatto dalla Function cCOLSum in Modulo1; se ci sono altri controlli da fare alle combinazioni calcolate quello e' l'aggancio in cui inserirsi.

Spero che trovi qualche spunto utile...
Avatar utente
Anthony47
Moderatore
 
Post: 16799
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: continuare un calcolo su di altro foglio

Postdi romant » 31/01/19 21:29

Ti ringrazio del tempo che hai dedicato cercando di risolvere il problema, vedo cosa riesco a fare con i tuoi consigli e indicazioni.
Giusto per discussione le altre macro servono per ridurre ancora di più le combinazioni, e come ho detto, contestualmente alle combinazioni, con il vincolo della somma, venivano visualizzati da quanti pari-dispari, e come erano composte in base a delle formule,
Select Case Cells(r, c)
Case Is <= 16 numeri inferiori a 16
f1 = f1 + 1
Case Is <= 33 numeri inferiori a 33 ma superiori a 16
f2 = f2 + 1
Case Is <= 50 numeri inferiori a 50 ma superiori a 33
f3 = f3 + 1
End Select
esempio: 5 8 20 35 41 composta da 2 pari e 3 dispari e formula 2.1.2 ( 5 e 8 inferiori a 16) (20 superiore a 16 ma inferiore a 33) ( 35 e 41 inferiore a 50 ma superiore a 33 ). segnando quale formula pari dispari( 2-3 ) vuoi cancellare, così come quale formula (2-2-1) le combinazioni si riducono. Il problema era solo quello che le combinazioni venivano poi scritte in colonne e, queste non erano sufficienti per le combinazioni, ecco il perché della mia richiesta….

Giusto per farti capire….
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35

Re: continuare un calcolo su di altro foglio

Postdi Anthony47 » 03/02/19 17:55

Ho modificato il file, reperibile sempre all'indirizzo gia' comunicato, per aggiungere due colonne allo sviluppo delle combinazioni (suddivisione per fasce, conteggio pari/dispari, come descritto nell'alrea tua discussione: viewtopic.php?f=26&t=110350)

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

Re: continuare un calcolo su di altro foglio

Postdi romant » 12/02/19 23:54

Sera Anthony, chiedo scusa se non ho risposto prima ma motivi personale non ho aperto il forum prima, vedo le revisione che hai fatto e ti faccio sapere. Comunque ti ringrazio
romant
Utente Junior
 
Post: 23
Iscritto il: 29/01/19 21:35


Torna a Applicazioni Office Windows


Topic correlati a "continuare un calcolo su di altro foglio":


Chi c’è in linea

Visitano il forum: Nessuno e 7 ospiti