Discussion :

[morobaboumar]

Bonjour membres du forum,
Pourriez vous m'aider comment écrire avec du code Vba les différents montants dans un seul champ
d'une requête ou d'un formulaire selon des paramètres ?

Voici mes codes:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
'Fonction Ramenant la part de la mère du défunt SANOGO Mouhamed LAMINE
'de la Famille du défunt Elhadji Mahmoud Sanogo (Paix divine éternelle à leurs âmes).
Public Function F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML(IDmontDec As Long, idMbreFEMS As Long, lienParentMere As Long) As Double
On Error GoTo MOROBABOUMAR
If IsNull(IDmontDec) Then Exit Function
If IsNull(idMbreFEMS) Then Exit Function
If IsNull(lienParentMere) Then Exit Function
Dim bd As Database
Dim R As Recordset
Dim sql As String
Set bd = CurrentDb
sql = "select * from [Req_Tbl_Gestion_ParticuliereChaqueHeritierEMS_2e_Fils] where NumMontantApartager = " & _
IDmontDec & _
" and ID_MembreFamille = " & idMbreFEMS & _
" and LienDeParente = " & lienParentMere & ";"
Set R = bd.OpenRecordset(sql)
With R
    If Not .EOF Then
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML = ((.Fields("Montant_Partager") - .Fields("MontantChargePchH_EMS")) / 114) * 19
    Else
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML = 0
    End If
End With
Exit Function
MOROBABOUMAR:
    MsgBox "Erreur n° " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Une erreur est survenue"
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
'Fonction Ramenant la part de chaque soeur du défunt SANOGO Mouhamed LAMINE
'de la Famille du défunt Elhadji Mahmoud Sanogo (Paix divine éternelle à leurs âmes).
Public Function F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartSoeur(IDmontDec As Long, idMbreFEMS As Long, lienParentMere As Long) As Double
On Error GoTo MOROBABOUMAR
If IsNull(IDmontDec) Then Exit Function
If IsNull(idMbreFEMS) Then Exit Function
If IsNull(lienParentMere) Then Exit Function
Dim bd As Database
Dim R As Recordset
Dim sql As String
Set bd = CurrentDb
sql = "select * from [Req_Tbl_Gestion_ParticuliereChaqueHeritierEMS_2e_FilsPartSoeur] where NumMontantApartager = " & _
IDmontDec & _
" and ID_MembreFamille = " & idMbreFEMS & _
" and LienDeParente = " & lienParentMere & ";"
Set R = bd.OpenRecordset(sql)
With R
    If Not .EOF Then
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartSoeur = ((.Fields("Montant_Partager") - .Fields("MontantChargePchH_EMS")) / 114) * 5
    Else
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartSoeur = 0
    End If
End With
Exit Function
MOROBABOUMAR:
    MsgBox "Erreur n° " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Une erreur est survenue"
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
'Fonction Ramenant la part de chaque frère du défunt SANOGO Mouhamed LAMINE
'de la Famille du défunt Elhadji Mahmoud Sanogo (Paix divine éternelle à leurs âmes).
Public Function F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartFrere(IDmontDec As Long, idMbreFEMS As Long, lienParentMere As Long) As Double
On Error GoTo MOROBABOUMAR
If IsNull(IDmontDec) Then Exit Function
If IsNull(idMbreFEMS) Then Exit Function
If IsNull(lienParentMere) Then Exit Function
Dim bd As Database
Dim R As Recordset
Dim sql As String
Set bd = CurrentDb
sql = "select * from [Req_Tbl_Gestion_ParticuliereChaqueHeritierEMS_2e_FilsPartFrere] where NumMontantApartager = " & _
IDmontDec & _
" and ID_MembreFamille = " & idMbreFEMS & _
" and LienDeParente = " & lienParentMere & ";"
Set R = bd.OpenRecordset(sql)
With R
    If Not .EOF Then
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartFrere = ((.Fields("Montant_Partager") - .Fields("MontantChargePchH_EMS")) / 114) * 10
    Else
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartFrere = 0
    End If
End With
Exit Function
MOROBABOUMAR:
    MsgBox "Erreur n° " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Une erreur est survenue"
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
'Fonction Ramenant la part de chaque fille de la défunte Hadja Djèné KABA
'de la Famille du défunt Elhadji Mahmoud Sanogo (Paix divine éternelle à leurs âmes).
Public Function F_RamenantMontantParticulierMembreFEMS_MoinsChargesHDK_PartFille(IDmontDec As Long, idMbreFEMS As Long, lienParentMere As Long) As Double
On Error GoTo MOROBABOUMAR
If IsNull(IDmontDec) Then Exit Function
If IsNull(idMbreFEMS) Then Exit Function
If IsNull(lienParentMere) Then Exit Function
Dim bd As Database
Dim R As Recordset
Dim sql As String
Set bd = CurrentDb
sql = "select * from [Req_Tbl_Gestion_ParticuliereChaqueHeritierEMS_Mere_PartFille] where NumMontantApartager = " & _
IDmontDec & _
" and ID_MembreFamille = " & idMbreFEMS & _
" and LienDeParente = " & lienParentMere & ";"
Set R = bd.OpenRecordset(sql)
With R
    If Not .EOF Then
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesHDK_PartFille = ((.Fields("Montant_Partager") - .Fields("MontantChargePchH_EMS")) / 19) * 1
    Else
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesHDK_PartFille = 0
    End If
End With
Exit Function
MOROBABOUMAR:
    MsgBox "Erreur n° " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Une erreur est survenue"
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
 
'Fonction Ramenant la part de chaque fils de la défunte Hadja Djèné KABA
'de la Famille du défunt Elhadji Mahmoud Sanogo (Paix divine éternelle à leurs âmes).
Public Function F_RamenantMontantParticulierMembreFEMS_MoinsChargesHDK_PartFils(IDmontDec As Long, idMbreFEMS As Long, lienParentMere As Long) As Double
On Error GoTo MOROBABOUMAR
If IsNull(IDmontDec) Then Exit Function
If IsNull(idMbreFEMS) Then Exit Function
If IsNull(lienParentMere) Then Exit Function
Dim bd As Database
Dim R As Recordset
Dim sql As String
Set bd = CurrentDb
sql = "select * from [Req_Tbl_Gestion_ParticuliereChaqueHeritierEMS_Mere_PartFrere] where NumMontantApartager = " & _
IDmontDec & _
" and ID_MembreFamille = " & idMbreFEMS & _
" and LienDeParente = " & lienParentMere & ";"
Set R = bd.OpenRecordset(sql)
With R
    If Not .EOF Then
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesHDK_PartFils = ((.Fields("Montant_Partager") - .Fields("MontantChargePchH_EMS")) / 19) * 2
    Else
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesHDK_PartFils = 0
    End If
End With
Exit Function
MOROBABOUMAR:
    MsgBox "Erreur n° " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Une erreur est survenue"
End Function

Voici sql de la requête "Req_PART_MONTANT_CHAQUE_HERITIER_SML_HDK"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
SELECT Tbl_Gestion_ParticuliereChaqueHeritierEMS.ID_MembreFamille, Tbl_Partage_Taux_Ses_Heritiers.IdGestionParticul, Tbl_Partage_Taux_Ses_Heritiers.LabelleSesHeritiers, Tbl_Partage_Taux_Ses_Heritiers.id_LienDeParente, Tbl_Partage_Taux_Ses_Heritiers.TauxNumerateurLP, Tbl_Partage_Taux_Ses_Heritiers.TauxDenomirateurLP, Tbl_Partage_Taux_Ses_Heritiers.IDMontantpartager, Tbl_Partage_Taux_Ses_Heritiers.IDChargePchH_EMS, F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML([Tbl_Partage_Taux_Ses_Heritiers]![IDMontantpartager],[Tbl_Gestion_ParticuliereChaqueHeritierEMS]![ID_MembreFamille],[Tbl_Partage_Taux_Ses_Heritiers]![id_LienDeParente]) AS MONTANT_MERE, F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartSoeur([Tbl_Partage_Taux_Ses_Heritiers]![IDMontantpartager],[Tbl_Gestion_ParticuliereChaqueHeritierEMS]![ID_MembreFamille],[Tbl_Partage_Taux_Ses_Heritiers]![id_LienDeParente]) AS MONTANT_SOEUR, F_RamenantMontantParticulierMembreFEMS_MoinsChargesSML_PartFrere([Tbl_Partage_Taux_Ses_Heritiers]![IDMontantpartager],[Tbl_Gestion_ParticuliereChaqueHeritierEMS]![ID_MembreFamille],[Tbl_Partage_Taux_Ses_Heritiers]![id_LienDeParente]) AS MONTANT_FRERE
FROM Tbl_Gestion_ParticuliereChaqueHeritierEMS INNER JOIN Tbl_Partage_Taux_Ses_Heritiers ON Tbl_Gestion_ParticuliereChaqueHeritierEMS.NumGestionParticul = Tbl_Partage_Taux_Ses_Heritiers.IdGestionParticul;

Mon objectif est de trouver un module unique qui englobe l'ensembles des codes précités.
Je requiers votre aide ?
Cordialement.

[morobaboumar]

Bonsoir membres du forum,
J'ai essayé cette méthode en attendant de trouver mieux:
1- en additionnant les résultats de chaque fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Montant_de_Chaque_Héritier: Nz([Montant_Total_Perçu_Epouse];0)+Nz([Montant_Total_Perçu_Fille];0)+Nz([Montant_Total_Perçu_Fils];0)

et ça me donne le résultat suivant (voir la capture d'écran)



Maintenant la fonction suivant me renvoie la moyenne du montant à partager par héritier et qui doit être multiplier par le taux de chaque membre.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
'Fonction Ramenant la part Moyenne des hértiers des défunts SANOGO Mouhamed LAMINE
'et Hadja Djéné KABA
'de la Famille du défunt Elhadji Mahmoud Sanogo (Paix divine éternelle à leurs âmes).
Public Function F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral(IDmontDec As Long, idMbreFEMS As Long, lienParentMere As Long) As Double
On Error GoTo MOROBABOUMAR
If IsNull(IDmontDec) Then Exit Function
If IsNull(idMbreFEMS) Then Exit Function
If IsNull(lienParentMere) Then Exit Function
Dim BD As Database
Dim R As Recordset
Dim sql As String
Set BD = CurrentDb
sql = "select * from [Req_Tbl_Gestion_ParticuliereChaqueHeritierEMS_General] where NumMontantApartager = " & _
IDmontDec & _
" and ID_MembreFamille = " & idMbreFEMS & _
" and LienDeParente = " & lienParentMere & ";"
Set R = BD.OpenRecordset(sql)
With R
    If Not .EOF Then
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral = ((.Fields("Montant_Partager") - .Fields("MontantChargePchH_EMS")) / 114)
    Else
    F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral = 0
    End If
End With
Exit Function
MOROBABOUMAR:
    MsgBox "Erreur n° " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Une erreur est survenue"
End Function

Voici comment je l'appelle dans la requête du formulaire:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

PART_Moyennne_DE_CHAQUE_HERITIER: F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral([IDMontantpartager];[ID_MembreFamille];[id_LienDeParente])

Sachant qu'ici:

- la mère du défunt détient les 1/6 du montant à partager ce qui lui donne droit (5+(7*2))= 19, alors elle aura un taux de 19 * le montant moyen ramené par la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral

- chaque des 5 sœurs ayant droit aux 1/2 du montant à partager ce qui donne droit à chacune
d'elles un taux de 5 * le montant moyen ramené par la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral

- Chaque frère ayant droit au double d'une sœur, alors le taux de chacun d'eux est
(5 * 2) = 10 * le montant moyen ramené par la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

F_RamenantMontantParticulierMembreFEMS_MoinsChargesGeneral

Voici le tableau:



Chers experts aidez moi à trouver le code vba qui m'aidera à ramener le montant de chaque
héritier ?

Si nécessaire je pourrait vous poster ma BD.

Dans l'espoir de trouver une solution favorable, merci pour tout le bien que vous nous apportez.

Cordialement.