Condividi:        

Macro Excel somma valori

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

Macro Excel somma valori

Postdi vmass86 » 24/01/12 10:05

Ciao a tutti,
sono nuovo del forum.
Volevo chiedere se qualcuno sa come costruire una macro excel che mi sappia indicare quali celle la cui somma mi restituisce un valore assegnato (o loro combinazioni)
Es. ho nella colonna A 15 15 30 20
voglio sapere quali celle mi danno somma 50
ed avrò 15 15 20 e 30 20

Vi ringrazio
ciao a tutti
vmass86
Newbie
 
Post: 6
Iscritto il: 24/01/12 10:00

Sponsor
 

Re: Macro Excel somma valori

Postdi Flash30005 » 24/01/12 12:08

Ciao Vmass86 e benvenuto nel Forum

Quanti numeri sono, 4?
da A2 a A5?
oppure sono in riga, A2:D2?

ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro Excel somma valori

Postdi vmass86 » 24/01/12 13:51

Ciao Flash
sono "n" valori in colonna (da A1 a A"n")
vmass86
Newbie
 
Post: 6
Iscritto il: 24/01/12 10:00

Re: Macro Excel somma valori

Postdi ricky53 » 24/01/12 14:15

Ciao,
hai un numero massimo di celle che possono essere gli addendi della somma?
Oppure le celle posono essere da una a "N" (tutte le celle del tuo intervallo nel caso limite) ?
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W10; Office 2003-10-13-16-19
Avatar utente
ricky53
Utente Senior
 
Post: 4565
Iscritto il: 11/04/09 19:29
Località: Italia

Re: Macro Excel somma valori

Postdi vmass86 » 24/01/12 14:18

Ciao Ricky
non ho un numero definito di celle. Possono andare da 1 a n
vmass86
Newbie
 
Post: 6
Iscritto il: 24/01/12 10:00

Re: Macro Excel somma valori

Postdi Anthony47 » 24/01/12 14:40

Dalla serie "ci sono piu' domande che risposte": E devi trovare "tutte" le combinazioni, da 1 a N elementi, che producono una somma arbitrariamente impostata?

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

Re: Macro Excel somma valori

Postdi vmass86 » 24/01/12 14:44

Ciao Anthony
Yes, in teoria avrei bisogno di tutte le combinazioni. E' possibile?
Altrimenti, avendo valori anche cifre decimali, è possibile che nella maggior parte dei casi la soluzione porti sempre una sola combinazione.
vmass86
Newbie
 
Post: 6
Iscritto il: 24/01/12 10:00

Re: Macro Excel somma valori

Postdi Flash30005 » 24/01/12 15:06

vmass86 ha scritto:in teoria avrei bisogno di tutte le combinazioni

Mizzica!!! :eeh:
In pratica se in quella colonna ci sono 50 (o più) valori con 1 bignognerebbe scovarli tutti!? :eeh:

Bel lavoro!!! 8)

A dopo...
ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro Excel somma valori

Postdi vmass86 » 24/01/12 15:27

Se è più semplice andrebbe bene anche che tenga conto una sola volta dei valori uguali
se ad esempio nella colonna cè
49 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 48 0,5 0,5
ed il valore somma è 50
la macro mi restituisce

49 + 1
49 +0,5 + 0,5
48 + 1 + 1
48 + 0,5 + 0,5 + 1

E' più fattibile?
vmass86
Newbie
 
Post: 6
Iscritto il: 24/01/12 10:00

Re: Macro Excel somma valori

Postdi Anthony47 » 25/01/12 02:52

Per puro esercizio ho sviluppato questo file: http://rapidshare.com/files/1402973321/ ... z_V1-3.xls

Prova a mettere i tuoi dati in Foglio1, da A2 verso il basso, poi lancia la macro CercaComb: ti verra' chiesto quale valore cercare (se inserisci un decimale devi usare il "punto" come separatore).
Il programma ha impostato un limite max delle combinazioni da testare e dei risultati positivi da restituire (che non puo' superare il numero di colonne); queste impostazioni sono nelle istruzioni marcate <<<

Non ci sono problemi a inserire un numero superiore di combinazioni, compatibilmente con la precisione di calcolo di excel e soprattutto col tempo che vorrete lasciare al pc per fare i suoi calcoli.

La macro fa un gioco di pazienza, provando le combinazioni possibii a gruppi di 1, poi di 2, poi di 3 e cosi' via fino al limite di combinazioni max impostate, e riporta nel foglio attivo (lo stesso che contiene in col A i numeri iniziali) le combinazioni man mano che si verificano. Prima di poter scrivere i risultati TUTTO IL FOGLIO viene cancellato, a parte il contenuto di colonna A.

Per futura memoria il codice e' il seguente:
Codice: Seleziona tutto
Dim VArr, WkArr(), WkIndex(), I As Integer, J As Integer, maxCol As Long, FlExit As Boolean
Dim Kappa As Integer, WResult As String, TgVal, LastLev As Integer, NElem As Integer

Sub CercaComb()
'
maxCol = 1500         '<<<  N° max di match
maxCombin = 2000000   '<<<  N° max di combinazioni che saranno testate
'

If maxCol > Columns.Count Then maxCol = Columns.Count - 3
TgVal = Val(InputBox("Valore target?"))
VArr = Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp))
NElem = UBound(VArr, 1)
ReDim WkArr(NElem): ReDim WkIndex(NElem)
Range("B1:IV1").Clear
Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp)).Offset(-1, 1).Resize(NElem + 1, maxCol).ClearContents
'
LastLev = 3
For I = 1 To NElem
    Col2h = Col2h + Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")")
        If Col2h > maxCombin Then Exit For
    Gruppidi = Gruppidi & " " & I
Next I
Rispo = MsgBox("N° di combinazioni massime testate: " & Col2h - _
    Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
    & "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
    & "Massimo " & maxCol & " risultati" & vbCrLf & vbCrLf _
    & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)
   
If Rispo = vbCancel Then Exit Sub

sTimer = Timer
For LastLev = 1 To I - 1
    For J = 0 To NElem
        WkArr(J) = "": WkIndex(J) = ""
    Next J
    Call Recur(1, NElem, 1)
Next LastLev
MsgBox ("Completato in " & Int(Timer - sTimer) & " Secondi" & vbCrLf _
    & "Rilevati " & Cells(1, Columns.Count).End(xlToLeft).Column & " match")
End Sub

Sub Recur(ByVal Iniz As Integer, ByVal Final As Integer, ByVal myLevel As Integer)
Dim myI As Integer, myK As Integer
For myI = Iniz To Final
    WkArr(myLevel) = VArr(myI, 1)
    WkIndex(myLevel) = myI
    If myLevel = LastLev Then
    If Application.WorksheetFunction.Sum(WkArr()) = TgVal And FlExit = False Then
        Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "x"
        mycol = Cells(1, Columns.Count).End(xlToLeft).Column
        If mycol > maxCol Then FlExit = True
        For myK = 1 To LastLev
            Cells(WkIndex(myK) + 1, mycol) = 1 'WkIndex(myK)
        Next myK
    End If
Else
    Call Recur(myI + 1, NElem, myLevel + 1)
    End If
If FlExit = True Then Exit For
Next myI
End Sub


Se siete curiosi provate anche voi.
Ciao a tutti.
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro Excel somma valori

Postdi Flash30005 » 25/01/12 08:37

Perfetto!!! :)
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro Excel somma valori

Postdi papiriof » 25/01/12 09:12

Anthony47 ha scritto:Per puro esercizio ho sviluppato questo file: https://rapidshare.com/files/231106756/ ... mbinaz.xls

Prova a mettere i tuoi dati in Foglio1, da A2 verso il basso, poi lancia la macro CercaComb: ti verra' chiesto quale valore cercare (se inserisci un decimale devi usare il "punto" come separatore).
Il programma ha impostato un limite max delle combinazioni da testare e dei risultati positivi da restituire (che non puo' superare il numero di colonne); queste impostazioni sono nelle istruzioni marcate <<<

Non ci sono problemi a inserire un numero superiore di combinazioni, compatibilmente con la precisione di calcolo di excel e soprattutto col tempo che vorrete lasciare al pc per fare i suoi calcoli.

La macro fa un gioco di pazienza, provando le combinazioni possibii a gruppi di 1, poi di 2, poi di 3 e cosi' via fino al limite di combinazioni max impostate, e riporta nel foglio attivo (lo stesso che contiene in col A i numeri iniziali) le combinazioni man mano che si verificano. Prima di poter scrivere i risultati TUTTO IL FOGLIO viene cancellato, a parte il contenuto di colonna A.

Per futura memoria il codice e' il seguente:
Codice: Seleziona tutto
Dim VArr, WkArr(), WkIndex(), I As Integer, J As Integer, maxCol As Long, FlExit As Boolean
Dim Kappa As Integer, WResult As String, TgVal, LastLev As Integer, NElem As Integer

Sub CercaComb()
'
maxCol = 1500         '<<<  N° max di match
maxCombin = 2000000   '<<<  N° max di combinazioni che saranno testate
'

If maxCol > Columns.Count Then maxCol = Columns.Count - 3
TgVal = Val(InputBox("Valore target?"))
VArr = Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp))
NElem = UBound(VArr, 1)
ReDim WkArr(NElem): ReDim WkIndex(NElem)
Range("B1:IV1").Clear
Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp)).Offset(-1, 1).Resize(NElem + 1, maxCol).ClearContents
'
LastLev = 3
For I = 1 To NElem
    Col2h = Col2h + Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")")
        If Col2h > maxCombin Then Exit For
    Gruppidi = Gruppidi & " " & I
Next I
Rispo = MsgBox("N° di combinazioni massime testate: " & Col2h - _
    Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
    & "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
    & "Massimo " & maxCol & " risultati" & vbCrLf & vbCrLf _
    & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)
   
If Rispo = vbCancel Then Exit Sub

sTimer = Timer
For LastLev = 1 To I - 1
    For J = 0 To NElem
        WkArr(J) = "": WkIndex(J) = ""
    Next J
    Call Recur(1, NElem, 1)
Next LastLev
MsgBox ("Completato in " & Int(Timer - sTimer) & " Secondi" & vbCrLf _
    & "Rilevati " & Cells(1, Columns.Count).End(xlToLeft).Column & " match")
End Sub

Sub Recur(ByVal Iniz As Integer, ByVal Final As Integer, ByVal myLevel As Integer)
Dim myI As Integer, myK As Integer
For myI = Iniz To Final
    WkArr(myLevel) = VArr(myI, 1)
    WkIndex(myLevel) = myI
    If myLevel = LastLev Then
    If Application.WorksheetFunction.Sum(WkArr()) = TgVal And FlExit = False Then
        Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "x"
        mycol = Cells(1, Columns.Count).End(xlToLeft).Column
        If mycol > maxCol Then FlExit = True
        For myK = 1 To LastLev
            Cells(WkIndex(myK) + 1, mycol) = 1 'WkIndex(myK)
        Next myK
    End If
Else
    Call Recur(myI + 1, NElem, myLevel + 1)
    End If
If FlExit = True Then Exit For
Next myI
End Sub


Se siete curiosi provate anche voi.
Ciao a tutti.

COMPLIMENTI !!!! devo vedere come utilizzarlo ( sto pensando al lotto :D ) certo che è bello forte!!!
Win 7+Office 2010
papiriof
Utente Senior
 
Post: 392
Iscritto il: 16/02/10 13:23

Re: Macro Excel somma valori

Postdi ricky53 » 25/01/12 12:38

Ciao Anthony:
siccome, come ben sai, sono MOLTO curioso ... mi hai provocato e .... posso dire

bell’esempio.
Inoltre non c’è bisogno che ti scriva che mi piace come ha redatto il codice : ben strutturato, essenziale, ottimizzato e .. .arguto.

RISULTATI delle mie prove:
ho scritto i dati in colonna “A” da “A2” fino a “A21”, tutti numeri interi.
ho lanciato la macro scritto 50 una volta, 5 l’altra, 2 ecc.
ho sempre un errore di run-time 13 nell’istruzione

Codice: Seleziona tutto
    Rispo = MsgBox("N° di combinazioni massime testate: " & Col2h - _
        Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
        & "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
        & "Massimo " & maxCol & " risultati" & vbCrLf & vbCrLf _
        & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)


Ho commentato l’istruzione riportata e tutto è andato bene.
Puoi controllare

Infine un refuso: il valore che mi fornisce come combinazioni trovate è maggiorato di “1”
Ossia il messaggio di fine elaborazione riporta una combinazione in più rispetto a quelle TROVATE !!!!
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W10; Office 2003-10-13-16-19
Avatar utente
ricky53
Utente Senior
 
Post: 4565
Iscritto il: 11/04/09 19:29
Località: Italia

Re: Macro Excel somma valori

Postdi Anthony47 » 25/01/12 13:37

La mia preoccupazione erano i grandi numeri, ma l' errore segnalato da Ricky si verifica con quelli piccoli: e' errato il calcolo della cardinalita' delle combinazioni; quindi, qualche riga prima dell' istruzione Msgbox che va in errore,
cancellare For I = 1 To NElem e sostituire con
Codice: Seleziona tutto
For I = 1 To NElem - 1

Infatti devo prevedere, dati N elementi, al max raggruppamenti di N-1

Correggero' il calcolo dei risultati visualizzati in una prossima Rev 1.1

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

Re: Macro Excel somma valori

Postdi Flash30005 » 25/01/12 14:14

Anche se, secondo me, non ha senso "chiedere" che la somma di n numeri risulti 5 o addirittura 2 visto l'utilizzo...
(l'esigenza era 50 ed ho provato 30 e sono risultati corretti)

@ papiriof
beh allora ti devi dare da fare perché la macro, per come è stata strutturata, processa la colonna A (da 2 a n righe), mentre, per la tua esigenza, credo debba processare ogni riga... per n righe
ma, si può fare, molto più semplicemente, come, normalmalmente adottato da questo tipo di analisi, la somma dei numeri di ogni estrazione per determinare i min e max delle somme
E... per fare al somma è sufficiente una semplice formula ad ogni riga ;)

ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro Excel somma valori

Postdi ricky53 » 25/01/12 15:30

Ciao Flash e Anthony,
premesso che un buon test va fatto con tutte le condizioni ... (ed un buon TESTER deve operare proprio in questo modo) ... Eh,Eh !!!

In colonna "A" ho inserito i numeri da 1 a 20
Prima ho provato scrivendo 50 nella InputBox ed ho avuto l'errore !!!
Successivamente ho provato con numeri piccoli proprio per verificare altre condizioni ed ho avuto sempre l'errore.

Infine ho provato in vari modi ed ho verificato che
con i numeri da 1 a 21 FUNZIONA con TUTTE le condizioni

Con la modifica apportata da Anthony funziona sempre !!!
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W10; Office 2003-10-13-16-19
Avatar utente
ricky53
Utente Senior
 
Post: 4565
Iscritto il: 11/04/09 19:29
Località: Italia

Re: Macro Excel somma valori

Postdi vmass86 » 27/01/12 14:16

Ciao a tutti
scusate il ritardo nella risposta ma sono stato fino ad oggi senza connessione :aaah

ho provato il file di anthony con la relativa correzione
funziona benissimo, proprio come ne avevo bisogno
faccio il revisore contabile ed uno strumento del genere mi è utilissimo 8)

grazie mille a tutti !
alla prox !
vmass86
Newbie
 
Post: 6
Iscritto il: 24/01/12 10:00

Re: Macro Excel somma valori

Postdi Anthony47 » 29/04/13 01:20

Vorrei segnalare la disponibilita' di una versione piu' aggiornata del file (https://rapidshare.com/files/1402973321 ... _V1-3.xls), pubblicato in risposta a questa discussione: viewtopic.php?f=26&t=99012&p=570059#p570047

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

Re: Macro Excel somma valori

Postdi Anthony47 » 21/12/13 02:45

Pubblico questa evoluzione della Versione_1-3, che consente la ricerca "per multipli" di un valore impostabile; il suo codice e' il seguente e sostituisce integralmente quello contenuto nel file pubblicato:
Codice: Seleziona tutto
Dim VArr, WkArr(), WkIndex(), I As Integer, J As Integer, maxCol As Long, FlExit As Boolean, myDec As Double, myGod2 As Double
Dim Kappa As Integer, WResult As String, TgVal, LastLev As Long, II As Long, NElem As Integer

Sub CercaComb305()
'Rev. 1.3.5
'B31221
'Modificato per cercare valori approssimati al multiplo fissato in A1
'es 1=arrotonda all'intero; 0,1=arrotonda a 1 decimale
'
Dim Col2H As Double, Col2K As Double, DataCol As Long
'
DataCol = 2         '<<< La colonna che contiene i dati da esaminare; 1=A, 2=B, etc
maxCol = 23         '<<<  N° max di match
MaxCombin = 20000000   '<<<  N° max di combinazioni che saranno testate
'
FlExit = False

'3.05>>>> Inserito gestione "multiplo"
myDec = Range("A1").Value: If myDec < 0.001 Then myDec = 0.001

If maxCol > Columns.Count Then maxCol = Columns.Count - DataCol - 2
TgVal = (InputBox("Valore target?"))
TgVal = Val(Replace(TgVal, ",", "."))    'Gestisce decimale sia "punto" che "virgola"
VArr = Range(Cells(2, DataCol), Cells(Rows.Count, DataCol).End(xlUp)).Value

NElem = UBound(VArr, 1)
ReDim WkArr(NElem): ReDim WkIndex(NElem)
Cells(1, DataCol + 1).Resize(NElem + 3, Columns.Count - 1 - Cells(1, DataCol).Column).Clear
'
LastLev = 3
For I = 1 To NElem - 1
'modificato per calcolare anche il tot delle combinazioni (uso di Col2K e II)
    Col2H = Col2H + Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")")
    If Col2H <= MaxCombin Then Col2K = Col2H - 1: II = I
    If Col2H <= MaxCombin Then Gruppidi = Gruppidi & " " & I
Next I

Rispo = MsgBox("Il valore target e': " & TgVal _
        & vbCrLf & "Impostato max combinazioni: " & Round(MaxCombin / 1000000, 1) & " Milioni" _
        & vbCrLf & "N° di combinazioni massime che saranno testate: " & Col2K - _
        Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
        & "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
        & "Massimo " & maxCol & " risultati" & vbCrLf _
        & "(Corrispondente al " & Int(Col2K / Col2H * 100) & "% delle possibili combinazioni)" & vbCrLf _
        & vbCrLf & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)
       

If Rispo = vbCancel Then Exit Sub
UserForm1.Show vbModeless
'3.05>>>> TGVal arrotondato al "multiplo" prescelto:
myGod2 = Round(TgVal / myDec, 0) * myDec

sTimer = Timer
'
If TgVal = 0 Then GoTo ZeroVal
'
For LastLev = 1 To II + 1
    For J = 0 To NElem
        WkArr(J) = "": WkIndex(J) = ""
    Next J
    Call Recur(1, NElem, 1)
DoEvents                           '???
Next LastLev
If FlExit = True Then mexflex = "(stop per limite di colonne massime da riportare)"
ZeroVal:
Unload UserForm1
MsgBox ("Completato in " & Format(Timer - sTimer, "0.0") & " Secondi" & vbCrLf & "Rilevati " & _
    Application.WorksheetFunction.CountIf(Range("1:1"), "x") _
    & " match" & vbCrLf & mexflex)
End Sub

Sub Recur(ByVal Iniz As Integer, ByVal Final As Integer, ByVal myLevel As Integer)
Dim myI As Integer, myK As Integer
For myI = Iniz To (Final - LastLev + myLevel)
   
    WkArr(myLevel) = VArr(myI, 1)
    WkIndex(myLevel) = myI
    If myLevel = LastLev Then 'Or (Round(Application.WorksheetFunction.Sum(WkArr()), 3)) > Round(TgVal, 3) Then

'3.05>>>>> Next riga modificata
        If (Round(Application.WorksheetFunction.Sum(WkArr()) / myDec, 0) * myDec) = myGod2 And FlExit = False Then
            Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "x"
            mycol = Cells(1, Columns.Count).End(xlToLeft).Column
            If mycol > maxCol Then FlExit = True
            For myK = 1 To LastLev
                Cells(WkIndex(myK) + 1, mycol) = 1  'WkIndex(myK)
            Next myK
'3.05>>>> Aggiunte sommatorie:
            Cells(NElem + 2, mycol) = Application.WorksheetFunction.Sum(WkArr())
            Cells(NElem + 3, mycol) = TgVal
        End If
    Else
        If Round(Application.WorksheetFunction.Sum(WkArr()), 3) > TgVal Then
'            Stop
            GoTo SkNxLev
'            Exit For
        End If
        Call Recur(myI + 1, NElem, myLevel + 1)
    End If
If FlExit = True Then Exit For
SkNxLev:
Next myI

WkArr(myLevel) = ""

End Sub
Con questo codice le ricerche vengono arrotondate a un multiplo impostabile in cella A1; es 1 in A1 significa che il valore target (impostato da inputbox) e i valori calcolati mentre si cercano le combinazioni sono tutte arrotondate all' unita'; 0,1 invece ricerca per valori arrotondati a 1 decimo; 5 significa che gli arrotondamenti sono fatti al multiplo di 5; etc. Il minimo arrotondamento e' 0,001; il max non esiste.
Per aiutare a calcolare le approssimazioni fatte, in coda all' elenco dei valori che combaciano con la ricerca fatta sono riportati:
-la somma esatta dei numeri
-il valore ricercato
Il risultato sara' come in figura (valore cercato 47789):
Immagine

Uploaded with ImageShack.us

Fatene buon uso...
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro Excel somma valori

Postdi Anthony47 » 30/12/13 23:46

Pubblicando la versione "3.05" mi fu chiaro che con un piccolo aggiustamento si poteva passare dal calcolo dell' approssimazione "al multiplo" ad una vera approssimazione in valore assoluto, tra l' altro molto piu' comprensibile. Tra una fetta di panettone e l' altra ho sviluppato quindi una nuova versione di macro, corrispondente al seguente codice (sostituisce in toto il codice precedente)
Codice: Seleziona tutto
Dim VArr, WkArr(), WkIndex(), I As Integer, J As Integer, maxCol As Long, FlExit As Boolean, myDec As Double, myGod2 As Double
Dim Kappa As Integer, WResult As String, TgVal, LastLev As Long, II As Long, NElem As Integer

Sub CercaComb306()
'Rev. 1.3.6
'B31221
'Modificato per cercare valori approssimati secondo la tolleranza +/- impostata in A1
'differenza minima misurata: 0,001
'
Dim Col2H As Double, Col2K As Double, DataCol As Long
'
DataCol = 2         '<<< La colonna che contiene i dati da esaminare; 1=A, 2=B, etc
maxCol = 100         '<<<  N° max di match
MaxCombin = 20000000   '<<<  N° max di combinazioni che saranno testate
'
FlExit = False

'3.06>>>> Questa e' la "tolleranza" sulle ricerche di uguaglianza
myDec = Range("A1").Value: If myDec < 0.001 Then myDec = 0.001

If maxCol > Columns.Count Then maxCol = Columns.Count - DataCol - 2
TgVal = (InputBox("Valore target?"))
TgVal = Val(Replace(TgVal, ",", "."))    'Gestisce decimale sia "punto" che "virgola"
VArr = Range(Cells(2, DataCol), Cells(Rows.Count, DataCol).End(xlUp)).Value

NElem = UBound(VArr, 1)
ReDim WkArr(NElem): ReDim WkIndex(NElem)
Cells(1, DataCol + 1).Resize(NElem + 4, Columns.Count - 1 - Cells(1, DataCol).Column).ClearContents
'
LastLev = 3
For I = 1 To NElem - 1
'modificato per calcolare anche il tot delle combinazioni (uso di Col2K e II)
    Col2H = Col2H + Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")")
    If Col2H <= MaxCombin Then Col2K = Col2H - 1: II = I
    If Col2H <= MaxCombin Then Gruppidi = Gruppidi & " " & I
Next I

Rispo = MsgBox("Il valore target e': " & TgVal & " con tolleranza +/-" & myDec _
        & vbCrLf & "Impostato max combinazioni: " & Round(MaxCombin / 1000000, 1) & " Milioni" _
        & vbCrLf & "N° di combinazioni massime che saranno testate: " & Col2K - _
        Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
        & "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
        & "Massimo " & maxCol & " risultati" & vbCrLf _
        & "(Corrispondente al " & Int(Col2K / Col2H * 100) & "% delle possibili combinazioni)" & vbCrLf _
        & vbCrLf & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)
       

If Rispo = vbCancel Then Exit Sub
UserForm1.Show vbModeless0
'3.05>>>> TGVal arrotondato al "multiplo" prescelto:
'myGod2 = Round(TgVal / myDec, 0) * myDec     'Superato in 3.06

sTimer = Timer
'
If TgVal = 0 Then GoTo ZeroVal
'
For LastLev = 1 To II + 1
    For J = 0 To NElem
        WkArr(J) = "": WkIndex(J) = ""
    Next J
    Call Recur(1, NElem, 1)
DoEvents                           '???
Next LastLev
If FlExit = True Then mexflex = "(stop per limite di colonne massime da riportare)"
ZeroVal:
Unload UserForm1
MsgBox ("Completato in " & Format(Timer - sTimer, "0.0") & " Secondi" & vbCrLf & "Rilevati " & _
    Application.WorksheetFunction.CountIf(Range("1:1"), "x") _
    & " match" & vbCrLf & mexflex)
Call ordina2003(DataCol)

End Sub

Sub Recur(ByVal Iniz As Integer, ByVal Final As Integer, ByVal myLevel As Integer)
Dim myI As Integer, myK As Integer, myCSum As Double
For myI = Iniz To (Final - LastLev + myLevel)
   
    WkArr(myLevel) = VArr(myI, 1)
    WkIndex(myLevel) = myI
    If myLevel = LastLev Then 'Or (Round(Application.WorksheetFunction.Sum(WkArr()), 3)) > Round(TgVal, 3) Then

'3.06>>>>> Next riga modificata per confrontare con la "tolleranza" impostata in A1
        myCSum = Application.WorksheetFunction.Sum(WkArr())
        If Abs(myCSum - TgVal) <= myDec And FlExit = False Then    'V_3.06, confronta con la "tolleranza" impostata in A1
            Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "x"
            mycol = Cells(1, Columns.Count).End(xlToLeft).Column
            If mycol > maxCol Then FlExit = True
            For myK = 1 To LastLev
                Cells(WkIndex(myK) + 1, mycol) = 1  'WkIndex(myK)
            Next myK
'3.05 e superiori >>>> Aggiunte sommatorie e delta (v 3.06):
            Cells(NElem + 2, mycol) = myCSum
            Cells(NElem + 3, mycol) = TgVal
            Cells(NElem + 4, mycol) = Abs(myCSum - TgVal)
        End If
    Else
'3.06 modificato confronto per gestire la tolleranza:
        If Round(Application.WorksheetFunction.Sum(WkArr()), 3) > (TgVal + myDec) Then    '3.06
'            Stop
            GoTo SkNxLev
'            Exit For
        End If
        Call Recur(myI + 1, NElem, myLevel + 1)
    End If
If FlExit = True Then Exit For
SkNxLev:
Next myI
'
WkArr(myLevel) = ""
'
End Sub


Sub ordina2003(ByVal Colonna As Long)
'Aggiunta per ordinare il blocco dei risultati
'
rowmax = Cells(Rows.Count, Colonna).End(xlUp).Row + 3
bbb = Application.WorksheetFunction.CountIf(Range("1:1"), "x")
Cells(1, Colonna + 1).Resize(rowmax, Application.WorksheetFunction.CountIf(Range("1:1"), "x")).Sort Key1:=Cells(rowmax, Colonna + 1), Order1:=xlAscending, Key2:=Cells(rowmax - 1, Colonna + 1) _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
End Sub

Va inserito in un Modulo tutto suo, sostituendo il codice precedente; la macro la lanciare e' la CercaComb306.
Il valore dell' approssimazione va impostato in A1; il valore minimo e' 0,001 (se omesso verra' impostato per default).

In coda alle combinazioni che producono il risultato approssimato cercato la macro riporta, su tre celle sottostanti: il totale della combinazione; il valore cercato, il Delta.
La tebella dei risultati viene poi ordinata per Delta crescente.
Un esempio dei risultati:
Immagine

Uploaded with ImageShack.us
Un file dimostrativo e' disponibile qui: http://rapidshare.com/share/DA3BDDF1CC0 ... F5D300415C

Fatene buon uso...

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

Prossimo

Torna a Applicazioni Office Windows


Topic correlati a "Macro Excel somma valori":


Chi c’è in linea

Visitano il forum: Gianca532011 e 83 ospiti