Macro Excel somma valori

[vmass86]

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

[Flash30005]

Ciao Vmass86 e benvenuto nel Forum

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

ciao

[vmass86]

Ciao Flash
sono "n" valori in colonna (da A1 a A"n")

[ricky53]

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) ?

[vmass86]

Ciao Ricky
non ho un numero definito di celle. Possono andare da 1 a n

[Anthony47]

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

[vmass86]

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.

[Flash30005]

in teoria avrei bisogno di tutte le combinazioni

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

Bel lavoro!!!

A dopo...
ciao

[vmass86]

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?

[Anthony47]

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.

[Flash30005]

Perfetto!!!

[papiriof]

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 ) certo che è bello forte!!!

[ricky53]

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 !!!!

[Anthony47]

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

[Flash30005]

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

[ricky53]

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 !!!

[vmass86]

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

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

grazie mille a tutti !
alla prox !

[Anthony47]

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

[Anthony47]

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):


Uploaded with ImageShack.us

Fatene buon uso...

[Anthony47]

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:


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

Fatene buon uso...

Ciao