Grazie a tutti per l'aiuto.

Moderatori: Dylan666, hydra, gahan
1.274,87
3.865,10
7.218,38 *
2.730,38
2.996,70
2.822,61
6.558,47
1.601,10
1.181,09
1.321,56 *
4.325,34
3.336,95
8.619,41
4.550,10 *
7.341,66
5.334,00
87,90
3.173,60
8.515,53
Sub binario()
totale# = 0
Rem qui verrà inserito l'importo da quadrare
totalone# = 13090.04
Rem qui verranno segnalate le righe degli importi che andranno a formare il totalone#
righe = ""
Rem valori che hai inserito da A1 in poi...
valori = 19
Do
x = x + 1
if x>2^(calori+1) then exit do
For t = 0 To valori
If x And (2 ^ t) Then
totale# = totale# + Range("a" & t + 1).Value
righe = righe & "A" & t + 1 & " "
End If
Next
If totale# = totalone# Then
MsgBox righe & vbCrLf & (totale#)
Exit Do
End If
totale# = 0
righe = ""
Loop
End Sub
gamma_ray ha scritto:volevo sapere se era possibile creare una formula che potesse individuare le combinazioni (tra i vari importi delle prestazioni) che potrebbero dare quel determinato totale generale (5610,12).
Sub BruteSolver()
Dim x As Double, MyRange As Range, bmax As Integer
Application.ScreenUpdating = False
Set valrange = Range("a1:a10")
Set MyRange = Range("b1:b10")
Set OutputCell = Range("f1")
Set WatchVal = Range("d1")
bmax = MyRange.Rows.Count
For n = 2 ^ bmax To 1 Step -1
x = n
'sai quanti addendi ti servono??
'se si togli l'apice a questo IF e metti il numero di addendi
'If Application.WorksheetFunction.Sum(MyRange)=8 then
If WatchVal.Value = 0 Then
Application.ScreenUpdating = True
MyRange.Copy OutputCell.Offset(0, c)
c = c + 1
Application.ScreenUpdating = False
End If
Application.StatusBar = n
'e togli l'apice anche a questo endif
'End If
Next n
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Function BinConArray(Dec As Double, BitMax As Integer, Optional Str As Boolean) As Variant
Dim Bit As Integer, BinArray As Variant
ReDim BinArray(BitMax - 1, BitMax - 1)
For i = BitMax To 1 Step -1
If Dec >= 2 ^ (i - 1) Then
Bit = 1
Dec = Dec - 2 ^ (i - 1)
Else
Bit = 0
End If
BinArray(0, j) = Bit
j = j + 1
Next i
For i = BitMax To 1 Step -1
BinArray(i - 1, 0) = BinArray(0, i - 1)
Next i
BinConArray = BinArray
End Function
If totale# = totalone# Then
MsgBox righe & vbCrLf & (totale#)
Exit Do '<==questo
End If
Sub binario()
totale# = 0
Rem importo da quadrare
totalone# = Range("B1").Value
Rem qui verranno segnalate le righe degli importi che andranno a formare il totalone#
righe = ""
Rem valori che hai inserito da A1 in poi...
valori = Range("B2").Value
Do
x = x + 1
If x > 2 ^ (valori) Then Exit Do
For t = 0 To valori
If x And (2 ^ t) Then
totale# = totale# + Range("a" & t + 1).Value
'Range("b" & t + 1).Value = Range("a" & t + 1).Value
righe = righe & "A" & t + 1 & " "
'Else
'Range("b" & t + 1).Value = 0
End If
Next
If Round(totale#, 2) = Round(totalone#, 2) Then
MsgBox righe & vbCrLf & (totale#)
'Exit Do
End If
totale# = 0
righe = ""
Loop
MsgBox ("elaborazione terminata")
End Sub
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
confrontare e evidenziare 2 fogli excel Autore: niccia |
Forum: Applicazioni Office Windows Risposte: 7 |
[EXCEL] controllo corrispondenza tra valori con un vincolo Autore: sbs |
Forum: Applicazioni Office Windows Risposte: 9 |
Visitano il forum: Nessuno e 70 ospiti