Une macro pour faire les comptes entre amis

Commenter

Contenu du snippet

C'est une macro (la plus simple possible) qui permet de faire les comptes entre amis en fonction de depenses, qui doit combien a qui?

L'optimisation du reglement des dettes est simple: on prend la personne qui doit le plus d'argent et celle qui doit recevoir le plus d'argent et on ajuste les 2 soldes... et ainsi de suite jusqu'a ce qu'il n'y ait plus de dettes.

Dans la worksheet, il faut juste qu'il y ait une feuille qui s'appelle "Depenses"
Il faut utiliser la colone A pour mettre le nom, B pour le montant et C pour l'intitule.
Les depenses doivent commencer ligne 3

Source / Exemple : 


Public Type depense

    Nom As String
    Total As Double
    Solde As Double

End Type

Public NBMAXPERS As Integer
Public depenses() As depense
Public nbPers As Integer

Sub calculComptes()

Dim i As Integer
Dim mess As String

NBMAXPERS = 15 'A modifier si besoin
ReDim depenses(NBMAXPERS)
nbPers = 0

'On supprime la feuille des remboursements si elle existe
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name = "Remboursements" Then
Application.DisplayAlerts = False
    ActiveWorkbook.Sheets(i).Delete
Application.DisplayAlerts = True
Exit For 'On cherche juste a supprimer cette feuille
End If
Next

Call getNoms
Call calculTotaux

'On afficher le total des depenses de chacun
mess = ""
For i = 0 To nbPers - 1
mess = mess & depenses(i).Nom & " a depense " & depenses(i).Total & vbCrLf
Next
MsgBox mess

Call calculDettes

End Sub

Private Sub getNoms()

Dim i As Integer
Dim line As Integer
Dim alreadyFound As Boolean

line = 3
Sheets("Depenses").Select
While Cells(line, "A").Value <> ""
alreadyFound = False
For i = 0 To nbPers - 1
If Cells(line, "A").Value = depenses(i).Nom Then alreadyFound = True
Next
If alreadyFound = False Then
depenses(i).Nom = Cells(line, "A").Value
depenses(i).Total = 0
nbPers = nbPers + 1
End If
line = line + 1
Wend

End Sub

Private Sub calculTotaux()

Dim line As Integer

line = 3
Sheets("Depenses").Select
While Cells(line, "A").Value <> ""
For i = 0 To nbPers - 1
If Cells(line, "A").Value = depenses(i).Nom Then
depenses(i).Total = depenses(i).Total + Cells(line, "B").Value
End If
Next
line = line + 1
Wend

End Sub

Private Sub calculDettes()

Dim nextLine As Integer
Dim i As Integer
Dim allDebtsCleared As Boolean
Dim totalGal As Double
Dim iMin As Integer 'l'indice du min local
Dim iMax As Integer 'l'indice du maximum local
Dim min As Double
Dim max As Double

totalGal = 0

'Calcul du montant dont chacun est redevable
For i = 0 To nbPers - 1
totalGal = totalGal + depenses(i).Total
Next

'Calcul des debiteurs et des crediteurs
For i = 0 To nbPers - 1
depenses(i).Solde = depenses(i).Total - (totalGal / nbPers)
Next

Sheets.Add.Name = "Remboursements"
Sheets("Remboursements").Move After:=Sheets(Sheets.Count)
Sheets("Remboursements").Select

'L'algorithme prend le plus gros debiteur et le corrige avec le plus gros crediteur
'et ainsi de suite en prennant apres le 2eme plus gros debiteur et le 2eme plus crediteur...

'on regarde si toutes les dettes ont ete reglees
allDebtsCleared = True
For i = 0 To nbPers - 1
If depenses(i).Solde <> 0 Then allDebtsCleared = False
Next

If allDebtsCleared = True Then
MsgBox "Personne ne doit rien a personne"
Exit Sub
End If

nextLine = 1
While allDebtsCleared = False

min = 0
max = 0

'On trouve notre plus gros debiteur et notre plus gros crediteur
For i = 0 To nbPers - 1
If depenses(i).Solde > max Then
max = depenses(i).Solde
iMax = i
End If
If depenses(i).Solde < min Then
min = depenses(i).Solde
iMin = i
End If
Next

If max > Abs(min) Then
depenses(iMin).Solde = 0
depenses(iMax).Solde = max - Abs(min)
Else
depenses(iMax).Solde = 0
depenses(iMin).Solde = min + max
End If

'On inscrit la dette
Cells(nextLine, "A").Value = depenses(iMin).Nom
Cells(nextLine, "B").Value = "doit"
Cells(nextLine, "C").Value = WorksheetFunction.min(max, Abs(min))
Cells(nextLine, "D").Value = "a"
Cells(nextLine, "E").Value = depenses(iMax).Nom

'on regarde si toutes les dettes ont ete reglees
allDebtsCleared = True
For i = 0 To nbPers - 1
If Int(depenses(i).Solde) <> 0 Then allDebtsCleared = False
Next

nextLine = nextLine + 1

Wend

MsgBox "Un ordre de virement a ete envoye aux comptes cencernes", vbExclamation
MsgBox "Non, je deconne :-)", vbInformation

End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_maisai)