Ciao Alessio,
Buongiorno, ho cercato anche tra le discussioni ma non ho trovate adatte...
non sono riuscito a trovare il sistema per far cercare ad excel (2003) un risultato definito tra un elenco di cifre.
Premetto che le vba non sono capace ne di crearle ne di usarle.
Se qualcuno sa aiutarmi lo ringrazio fin da ora.
Mi spiego meglio:
La somma di alcune cifre (senza ripetizione) scritte in A2:A500 danno il risultato scritto in C2
Quali sono le cifre che danno questo risultato?
Mi servirebbe un file poi gestibile, in cui posso cambiare gli importi scritti in A2:A500 ed in C2
Esempio:
A2 5,15 C2 = 12,74
A3 8,54
A4 6,80
A5 4,20
A6 2,20
A7 2,00
Il file excell mi dovrebbe dire le varie possibilità che ci sono, quindi: A3 ( 8,54 ) + A5 ( 4,20 ) e A3 ( 8,54 ) + A6 ( 2,20 ) + A7 ( 2,00 )
Prova come segue:
- Alt+F11 per aprire l'editor di VBA
- Alt+IM per inserire un nuovo modulo di codice
- Nel nuovo modulo vuoto, incolla il seguente codice:
'=========>>
Option Explicit
Const OUTPUTWSN As String = "Soluzioni Trovate" '\modifica a piacere
'--------->>
Public Sub FindSums()
'==============
'\ Codice basato sul codice originale di Harlan Grove
'\ Codice adattato da NDJ per utilizzare late binding late
Const TOL As Double = 0.000001 'modify as needed
Dim c As Variant
Dim j As Long, k As Long, n As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim v As Variant, x As Variant, y As Variant
Dim dc1 As Object, dc2 As Object
Dim dcn As Object, dco As Object
Dim re As Object
Dim arrKeys As Variant
Dim arrItems As Variant
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.IgnoreCase = True
On Error Resume Next
Set x = Application.InputBox( _
Prompt:="Seleziona l'intervallo degli addendi:", _
Title:="TrovaSomme", _
Default:="", _
Type:=8)
If x Is Nothing Then
Err.Clear
Exit Sub
End If
y = Application.InputBox( _
Prompt:="Immetti il totale da cercare:", _
Title:="findsums", _
Default:="", _
Type:=1)
If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If
On Error GoTo 0
Set dc1 = CreateObject("Scripting.Dictionary") 'New dictionary
Set dc2 = CreateObject("Scripting.Dictionary") 'New dictionary
Set dco = dc1
Set dcn = dc2
Call recsoln
For Each y In x.Value2
If VarType(y) = vbDouble Then
If Abs(t - y) < TOL Then
recsoln "+" & Format(y)
ElseIf dco.Exists(y) Then
dco(y) = dco(y) + 1
ElseIf y < t - TOL Then
dco.Add Key:=y, Item:=1
c = CDec(c + 1)
Application.StatusBar = "[1] " & Format(c)
End If
End If
Next y
n = dco.Count
ReDim v(1 To n, 1 To 3)
arrKeys = dco.Keys
arrItems = dco.Items
For k = 1 To n
v(k, 1) = arrKeys(k - 1)
v(k, 2) = arrItems(k - 1)
Next k
qsortd v, 1, n
For k = n To 1 Step -1
v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
If v(k, 3) > t Then dcn.Add Key:="+" & _
Format(v(k, 1)), Item:=v(k, 1)
Next k
On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For k = 2 To n
dco.RemoveAll
swapo dco, dcn
For Each y In dco.Keys
p = False
For j = 1 To n
If v(j, 3) < t - dco(y) - TOL Then Exit For
x = v(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True
If p Then
re.Pattern = "" & s & "(?=(+|$))"
If re.Execute(y).Count < v(j, 2) Then
u = dco(y) + x
If Abs(t - u) < TOL Then
recsoln y & s
ElseIf u < t - TOL Then
dcn.Add Key:=y & s, Item:=u
c = CDec(c + 1)
Application.StatusBar = _
"[" & Format(k) & "] " & Format(c)
End If
End If
End If
Next j
Next y
If dcn.Count = 0 Then Exit For
Next k
If (recsoln() = 0) Then
MsgBox Prompt:="Esaurite tutte le combinazioni", _
Title:="Niente Soluzione!"
Else
ThisWorkbook.Sheets(OUTPUTWSN).Columns(1).AutoFit
MsgBox Prompt:="Si trova le soluzioni sul foglio: " & OUTPUTWSN, _
Buttons:=vbInformation, _
Title:="SOLUZIONI"
End If
CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
'--------->>
Private Function recsoln(Optional s As String)
Static r As Range
Dim ws As Worksheet
If s = "" And r Is Nothing Then
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
If ws Is Nothing Then
Err.Clear
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
r.Parent.Name = OUTPUTWSN
ws.Activate
Application.ScreenUpdating = False
Else
ws.Cells.Clear
Set r = ws.Range("A1")
End If
recsoln = 0
ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing
Else
r.Value = s
Set r = r.Offset(1, 0)
recsoln = r.Row - 1
End If
End Function
'--------->>
Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161
Dim j As Long, pvt As Long
If (lft >= rgt) Then Exit Sub
swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
pvt = lft
For j = lft + 1 To rgt
If v(j, 1) > v(lft, 1) Then
pvt = pvt + 1
swap2 v, pvt, j
End If
Next j
swap2 v, lft, pvt
qsortd v, lft, pvt - 1
qsortd v, pvt + 1, rgt
End Sub
'--------->>
Private Sub swap2(v As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161
Dim t As Variant, k As Long
For k = LBound(v, 2) To UBound(v, 2)
t = v(i, k)
v(i, k) = v(j, k)
v(j, k) = t
Next k
End Sub
'--------->>
Private Sub swapo(a As Object, b As Object)
Dim t As Object
Set t = a
Set a = b
Set b = t
End Sub
'<<=========
- Alt+Q per chiudere l'editor di VBA e tornare a Excel
- Salva il file con l’estensione xlsm
- Alt+F8 per aprire la finestra di gestione delle macro
- Seleziona Tester
- Esegui
===
Regards,
Norman
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
