Post by SIAE260Post by SIAE260Aiuto per favore.... perdo ore al giorno per trovare un dato valore.
Vi spiego. La nostra banca ci invia un listato di tutte le fatture
incassate in un intervallo di tempo. Al tempo stesso ci invia anche un
estratto conto con i movimenti del conto corrente. il problema è che
troviamo importi in accredito che non sono la somma integrale della
lista delle fatture incassate,ma solo una parte.
Succede così che se per esempio ho una lista di incassi per un valore
di 24.654 € , ho dall'altra parte un accredito di 8.527.
Ho la necessità di trovare quali importi della lista mi portano al
valore di 8.527 !!!
A incastrare manualmente questi conti è un terno al lotto. Sapete
indicarmi, se è possibile come risolvere questo mio problema con
excel?
Grazie per il vostro preziosissimo aiuto.
A presto
http://www.microsoft.com/office/community/it-it/default.mspx?&query=r....
ciao
r
Grazie, ho letto.... bhe li si parla di ben 98 possibili
combinazioni... io molte meno, ma capisco il problema.
Comunque grazie
Per cucchiaino: Ovviamente grazie anche a te. Almeno mi avete risposto. ;-)
ciao
forse non hai letto tutto ...
Norman suggerì questa stupenda
procedura di Harlan Grove ....
la riporto, visto che hai detto che
i numeri sono non molti, questo fa
al caso tuo!
Norman scrisse:
utilizzerei il seguente codice creato da Harlan Grove
- noti che è necessario da aggiungere i riferimenti a
Microsoft Scripting Runtime e Microsoft VBScript
Regular Expressions 1.0
=====================>>
Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove
Sub FindSums()
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 New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp
re.Global = True
re.IgnoreCase = True
On Error Resume Next
Set x = Application.InputBox( _
Prompt:="Enter range of values:", _
Title:="findsums", _
Default:="", _
Type:=8 _
)
If x Is Nothing Then
Err.Clear
Exit Sub
End If
y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)
If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If
On Error GoTo 0
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)
For k = 1 To n
v(k, 1) = dco.Keys(k - 1)
v(k, 2) = dco.Items(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:="all combinations exhausted", Title:="No Solution"
CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste
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
<<=================
---
Regards,
Norman
Microsoft Excel MVP