Option Base 1
Public profondeur, total, cible, depart, fin, compteur, total_permutations, total_combinaisons, tval()
Sub lettrage()
Rem Rapprochement d'un montant unique avec une série de montants
Rem par BARONE Jean-Marie 02/2006
Rem version 1.0
Rem [url=http://euromatic.online.fr]EUROMATIC ® for Windows 95/98/Me/3.11[/url]
total = 0
profondeur = InputBox("Entrez le nombre maximum de cellules à rapprocher", _
"Profondeur de recherche", 5)
cible = InputBox("Entrez la Valeur Cible recherchée", "Montant à rapprocher", _
ActiveSheet.Range("H1").Value)
depart = InputBox("Entrez la Cellule de départ", "Plage de Recherche", "E2")
fin = InputBox("Entrez la Cellule de fin", "Plage de Recherche", "E34")
nb_cells = Range(depart, fin).Cells.Count
compteur = 0
total_permutations = 0
total_combinaisons = 0
Range("w1").Value = Now
For x = profondeur To 1 Step -1
total_permutations = total_permutations + _
Application.WorksheetFunction.Permut(nb_cells, x)
total_combinaisons = total_combinaisons + _
Application.WorksheetFunction.Combin(nb_cells, x)
Next x
Call recursivite(depart)
info = MsgBox("Aucun rapprochement trouvé", vbInformation, "Terminé")
Application.StatusBar = False
Range("j2").Value = Now
End Sub
Sub recursivite(debut)
profondeur = profondeur - 1
Application.StatusBar = "Total Permutations = " + CStr(total_permutations) + Space(2) + _
"Total Combinaisons =" + CStr(total_combinaisons) + Space(2) + "Progression =" _
+ CStr(Format((compteur / total_combinaisons), "0.00%"))
For Each cell In Range(debut, fin)
If cell.Interior.ColorIndex = 8 Then GoTo next_cell
cell.Interior.ColorIndex = 8
total = total + cell.Value
compteur = compteur + 1
If Format(total, "###0.00") = Format(cible, "###0.00") Then
Range("w2").Value = Now
info = MsgBox("Valeur Cible trouvée!", vbExclamation, "Terminé")
Application.StatusBar = False
End
End If
If profondeur > 0 Then Call recursivite(cell.Address())
cell.Interior.ColorIndex = 2
total = total - cell.Value
next_cell: Next cell
profondeur = profondeur + 1
End Sub