Code VBA Complexe pour suivi, insertion et modification

Le 04/09/2025 à 13:10
bonjour
je me permet de solliciter votre expertise afin de finaliser mon projet (un fichier de 12 méga malheureusement je ne peux pas le uploader).
ceci dit, je suis bloquer sur ce code: Sub ModifierEcheancierPaiements_AvecSecurite()
vous verrez qu'un call est effectué pour Sub GenererEcheancierPaiements_CODE_OK()
ce qui me bloque c'est les calculs des proratas ils ne sont pas juste et ne suivent pas la régle suivante:
CAS C : L'ÉCHÉANCE EST DÉJÀ PAYÉE (Découpage de la ligne avec prorata ET rattrapage):
si la date de debut d'echeance est <= 15 d'un mois m(dans cet exemple fevrier),le mois m doit etre pris en compte.
quand la fin de la date d'echeance est <=15 d'un mois m, le m-1 doit etre pris en compte
si la date de debut d'echeance est >= 16 d'un mois m, le m+1 doit etre pris en compte.
si la fin de la date d'echeance est <16 d'un mois m, le m-1 doit etre pris en compte
CAS B : L'ÉCHÉANCE N'EST PAS ENCORE PAYÉE (Coupure de la ligne):
si la date de debut d'echeance est >= 16 d'un mois m, le m+1 doit etre pris en compte.
si la fin de la date d'echeance est <16 d'un mois m, le m-1 doit etre pris en compte
' --- NOUVEAU : Définir le mot de passe ici ---
Const MOT_DE_PASSE As String = "ExcelVBA2025" ' <-- CHANGEZ CECI !
' --- 1. DÉCLARATION DES VARIABLES ---
Dim wsAffichage As Worksheet, wsPaiement As Worksheet
Dim codeOracleAModifier As String
Dim derniereLigne As Long, i As Long
Dim reponse As VbMsgBoxResult
Dim lignesSupprimees As Long
' --- 2. INITIALISATION ---
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Set wsAffichage = ThisWorkbook.Worksheets("AFFICHAGE & INSERTION")
Set wsPaiement = ThisWorkbook.Worksheets("GLOBAL PAYMENT")
On Error GoTo 0
If wsAffichage Is Nothing Or wsPaiement Is Nothing Then
MsgBox "Erreur: Une des feuilles requises n'a pas été trouvée.", vbCritical
GoTo Fin
End If
' --- 3. RÉCUPÉRATION DU CODE ORACLE ET VÉRIFICATION ---
codeOracleAModifier = Trim(wsAffichage.Range("C3").Value)
If codeOracleAModifier = "" Then
MsgBox "Aucun 'C0DE ORACLE' n'est présent. Veuillez d'abord rechercher un site.", vbExclamation
GoTo Fin
End If
' --- 4. CONFIRMATION DE L'UTILISATEUR ---
reponse = MsgBox("Vous êtes sur le point de mettre à jour l'échéancier pour le site '" & codeOracleAModifier & "'." & vbCrLf & vbCrLf & _
"Toutes les lignes de paiement existantes pour ce site seront supprimées et recréées." & vbCrLf & vbCrLf & _
"Êtes-vous sûr de vouloir continuer ?", vbQuestion + vbYesNo, "Confirmation de la Mise à Jour")
If reponse = vbNo Then
MsgBox "Mise à jour annulée.", vbInformation
GoTo Fin
End If
' --- 5. OPÉRATIONS SUR LA FEUILLE (AVEC DÉVERROUILLAGE) ---
On Error GoTo ErreurProtection ' Si le mdp est mauvais, on gère l'erreur
' NOUVEAU : Déverrouiller la feuille de paiement
wsPaiement.Unprotect Password:=MOT_DE_PASSE
lignesSupprimees = 0
derniereLigne = wsPaiement.Cells(wsPaiement.Rows.count, "B").End(xlUp).Row
For i = derniereLigne To 3 Step -1
If Trim(wsPaiement.Cells(i, "B").Value) = codeOracleAModifier Then
wsPaiement.Rows(i).Delete
lignesSupprimees = lignesSupprimees + 1
End If
Next i
' --- 6. RÉGÉNÉRATION DU NOUVEL ÉCHÉANCIER ---
If lignesSupprimees > 0 Then
Call GenererEcheancierPaiements_CODE_OK ' Assurez-vous que le nom est exact
Else
reponse = MsgBox("Aucun échéancier existant n'a été trouvé pour le site '" & codeOracleAModifier & "'." & vbCrLf & _
"Voulez-vous le créer maintenant ?", vbQuestion + vbYesNo, "Créer un nouvel échéancier ?")
If reponse = vbYes Then
Call GenererEcheancierPaiements_CODE_OK
Else
MsgBox "Opération annulée.", vbInformation
End If
GoTo Fin ' On saute le message de succès final
End If
MsgBox "L'échéancier a été mis à jour avec succès. "
' --- 7. FINALISATION ET GESTION D'ERREURS ---
Fin:
' NOUVEAU : Re-verrouiller la feuille dans tous les cas avant de quitter
If Not wsPaiement Is Nothing Then
wsPaiement.Protect Password:=MOT_DE_PASSE, AllowFiltering:=True ' AllowFiltering permet de garder les filtres actifs
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub ' On sort de la procédure proprement
ErreurProtection:
MsgBox "Le mot de passe pour déverrouiller la feuille est incorrect ou une autre erreur de protection est survenue.", vbCritical, "Erreur de Protection"
GoTo Fin ' On va directement à la fin pour nettoyer
End Sub
Sub GenererEcheancierPaiements_CODE_OK()
' --- NOUVEAU : Définir le mot de passe ici ---
Const MOT_DE_PASSE As String = "ExcelVBA2025" ' <-- CHANGEZ CECI !
' --- 1. DÉCLARATION DES VARIABLES ---
Dim wsAffichage As Worksheet, wsPaiement As Worksheet
' Données du formulaire
Dim codeOracle As String, dateDebutContrat As Date, dureeContrat As Long
Dim tauxMajoration As Double, frequenceMajoration As Long, modalitePaiement As Double
' Variables de calcul
Dim nbPaiementsParAn As Long, dureePeriodeMois As Long, totalPaiementsParBeneficiaire As Long
Dim nbBeneficiairesReels As Long, lignesTotalesAGenerer As Long
Dim dateDebutPeriode As Date, dateFinPeriode As Date
Dim anneesEcoulees As Long, nbMajorationsAppliquees As Long, facteurMajoration As Double
' Variables de boucle
Dim i As Long, j As Long
Dim ligneDest As Long
' --- 2. INITIALISATION ET SÉCURITÉ ---
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set wsAffichage = ThisWorkbook.Worksheets("AFFICHAGE & INSERTION")
Set wsPaiement = ThisWorkbook.Worksheets("GLOBAL PAYMENT")
On Error GoTo 0
If wsAffichage Is Nothing Or wsPaiement Is Nothing Then
MsgBox "Erreur: Assurez-vous que les feuilles 'AFFICHAGE & INSERTION' et 'GLOBAL PAYMENT' existent.", vbCritical
GoTo Fin
End If
' --- 3. LECTURE ET VÉRIFICATION DES DONNÉES DU FORMULAIRE ---
With wsAffichage
codeOracle = .Range("C3").Value
If Not IsDate(.Range("C5").Value) Then MsgBox "La date d'entrée en vigueur (C5) est invalide.", vbCritical: GoTo Fin
dateDebutContrat = .Range("C5").Value
If Not IsNumeric(.Range("C11").Value) Or .Range("C11").Value <= 0 Then MsgBox "La durée du contrat (C11) est invalide.", vbCritical: GoTo Fin
dureeContrat = .Range("C11").Value
tauxMajoration = .Range("C12").Value
If Not IsNumeric(.Range("C13").Value) Or .Range("C13").Value <= 0 Then MsgBox "La fréquence de majoration (C13) est invalide.", vbCritical: GoTo Fin
frequenceMajoration = .Range("C13").Value
If Not IsNumeric(.Range("C14").Value) Or .Range("C14").Value <= 0 Then MsgBox "La modalité de paiement (C14) est invalide.", vbCritical: GoTo Fin
modalitePaiement = .Range("C14").Value
End With
If Trim(codeOracle) = "" Then MsgBox "Le 'C0DE ORACLE' (C3) est vide.", vbCritical: GoTo Fin
' NOUVEAU : Déverrouiller la feuille de paiement
wsPaiement.Unprotect Password:=MOT_DE_PASSE
' --- 4. CALCULS PRÉCIS ET CONFIRMATION AMÉLIORÉE ---
' NOUVEAU: Compter le nombre réel de bénéficiaires saisis
nbBeneficiairesReels = Application.WorksheetFunction.CountA(wsAffichage.Range("G3:G17"))
' Si aucun bénéficiaire n'est trouvé, on arrête
If nbBeneficiairesReels = 0 Then
MsgBox "Aucun bénéficiaire n'a été trouvé pour ce site. L'opération est annulée.", vbInformation, "Aucun Bénéficiaire"
GoTo Fin
End If
' ===================================================================
' <-- AJOUTEZ CE BLOC DE VÉRIFICATION ICI
' --- VÉRIFICATION N°1 : COHÉRENCE DES MONTANTS ---
' On appelle notre fonction. Si elle renvoie False, on s'arrête.
If VerifierCoherenceBaux() = False Then
GoTo ExitRoutine ' Arrête la macro car une erreur de cohérence a été trouvée.
End If
' ===================================================================
'#######################################################CODE POUR EVITER L'INSERTION EN DOUBLE###########################
Dim celluleTrouvee As Range
Dim plageRecherche As Range
Set plageRecherche = wsPaiement.Range("B2:B" & wsPaiement.Cells(wsPaiement.Rows.count, "B").End(xlUp).Row)
Set celluleTrouvee = plageRecherche.Find(What:=codeOracle, LookIn:=xlValues, LookAt:=xlWhole)
' Si la cellule a été trouvée (c'est-à-dire que le code existe déjà)
If Not celluleTrouvee Is Nothing Then
MsgBox "Le CODE SITE '" & codeSite & "' existe déjà sur la ligne " & celluleTrouvee.Row & "." & vbCrLf & _
"Insertion annulée pour éviter les doublons.", vbCritical, "Doublon Détecté"
GoTo ExitRoutine ' On arrête la macro
End If
'#######################################################CODE POUR EVITER L'INSERTION EN DOUBLE###########################
' Calcul des paramètres
nbPaiementsParAn = Round(1 / modalitePaiement)
dureePeriodeMois = 12 / nbPaiementsParAn
totalPaiementsParBeneficiaire = dureeContrat * nbPaiementsParAn
lignesTotalesAGenerer = nbBeneficiairesReels * totalPaiementsParBeneficiaire
' NOUVEAU: Message de confirmation précis
If MsgBox("Ce site a " & nbBeneficiairesReels & " bénéficiaire(s)." & vbCrLf & _
"Un total de " & lignesTotalesAGenerer & " lignes d'échéancier va être généré." & vbCrLf & vbCrLf & _
"Voulez-vous continuer ?", vbQuestion + vbYesNo, "Confirmation de la Génération") = vbNo Then
GoTo Fin
End If
' Trouver la première ligne vide dans la feuille de destination
ligneDest = wsPaiement.Cells(wsPaiement.Rows.count, "A").End(xlUp).Row + 1
If ligneDest < 3 Then ligneDest = 3
' --- 5. BOUCLE PRINCIPALE ---
' Boucle sur les 15 emplacements possibles de bénéficiaires
For i = 3 To 17
' On ne traite que si le nom du bénéficiaire existe
If Trim(wsAffichage.Cells(i, "G").Value) <> "" Then
' Boucle sur chaque période de paiement pour CE bénéficiaire
For j = 1 To totalPaiementsParBeneficiaire
' --- A. CALCULS POUR LA PÉRIODE ---
dateDebutPeriode = DateAdd("m", (j - 1) * dureePeriodeMois, dateDebutContrat)
dateFinPeriode = DateAdd("m", j * dureePeriodeMois, dateDebutContrat)
anneesEcoulees = DateDiff("yyyy", dateDebutContrat, dateDebutPeriode)
nbMajorationsAppliquees = 0
If frequenceMajoration > 0 Then nbMajorationsAppliquees = Fix(anneesEcoulees / frequenceMajoration)
facteurMajoration = (1 + tauxMajoration) ^ nbMajorationsAppliquees
' --- B. ÉCRITURE DES DONNÉES DANS LA FEUILLE "GLOBAL PAYMENT" ---
' Note: Je reprends la structure que vous aviez appréciée dans le premier code.
' Adaptez les colonnes si nécessaire.
wsPaiement.Cells(ligneDest, "A").Value = wsAffichage.Range("C2").Value ' WILAYA
wsPaiement.Cells(ligneDest, "B").Value = wsAffichage.Range("C3").Value ' CODE ORACLE
wsPaiement.Cells(ligneDest, "D").Value = wsAffichage.Range("C4").Value ' NOM DU SITE
wsPaiement.Cells(ligneDest, "E").Value = wsAffichage.Range("C5").Value ' DATE ENREE EN VIGUEUR DU PAIEMENT
wsPaiement.Cells(ligneDest, "F").Value = wsAffichage.Range("C6").Value ' BAIL GLOBAL A LA SIGNATURE
wsPaiement.Cells(ligneDest, "G").Value = wsAffichage.Range("C7").Value ' BAIL 2G
wsPaiement.Cells(ligneDest, "H").Value = wsAffichage.Range("C8").Value ' BAIL 3G
wsPaiement.Cells(ligneDest, "I").Value = wsAffichage.Range("C9").Value ' BAIL 4G
wsPaiement.Cells(ligneDest, "J").Value = wsAffichage.Range("C10").Value ' BAIL 5G
wsPaiement.Cells(ligneDest, "W").Value = wsAffichage.Range("C11").Value ' DUREE DU CONTRAT PAR ANNEE
wsPaiement.Cells(ligneDest, "X").Value = wsAffichage.Range("C12").Value ' TAUX DE MAJORATION
wsPaiement.Cells(ligneDest, "Y").Value = wsAffichage.Range("C13").Value ' MAJORATION APPLIQUEE CHAQUE (PAR ANNEE)
wsPaiement.Cells(ligneDest, "Z").Value = wsAffichage.Range("C14").Value ' MODALITE DE PAIEMENT (UNITE ANNEE)
wsPaiement.Cells(ligneDest, "AA").Value = wsAffichage.Range("C15").Value ' ADRESSE DU SITE
wsPaiement.Cells(ligneDest, "AB").Value = wsAffichage.Range("C16").Value ' MODE DE PAIEMENT
wsPaiement.Cells(ligneDest, "AC").Value = wsAffichage.Range("C17").Value ' SUPERFICIE DU SITE (M²)
wsPaiement.Cells(ligneDest, "AD").Value = wsAffichage.Range("C18").Value ' STATUT DU PROPRIETAIRE
wsPaiement.Cells(ligneDest, "AE").Value = wsAffichage.Range("C19").Value ' STATUT DU SITE
' ... etc. pour les autres données communes du site
' Données calculées de la période
wsPaiement.Cells(ligneDest, "K").Value = dateDebutPeriode
wsPaiement.Cells(ligneDest, "L").Value = dateFinPeriode
wsPaiement.Cells(ligneDest, "M").Value = anneesEcoulees + 1 ' Année 1, Année 2...
' Données spécifiques au bénéficiaire
wsPaiement.Cells(ligneDest, "N").Value = wsAffichage.Cells(i, "E").Value ' N° BENEFICIAIRE
wsPaiement.Cells(ligneDest, "O").Value = wsAffichage.Cells(i, "G").Value ' NOM DU BENEFICIAIRE
wsPaiement.Cells(ligneDest, "P").Value = wsAffichage.Cells(i, "H").Value ' N° DE COMMANDE BENEFICIAIRE
wsPaiement.Cells(ligneDest, "Q").Value = wsAffichage.Cells(i, "I").Value ' N° DE COMPTE
wsPaiement.Cells(ligneDest, "C").Value = wsAffichage.Cells(i, "F").Value ' CANDIDAT
' Montants des baux majorés pour la période
wsPaiement.Cells(ligneDest, "R").Value = wsAffichage.Cells(i, "J").Value * facteurMajoration
wsPaiement.Cells(ligneDest, "S").Value = wsAffichage.Cells(i, "K").Value * facteurMajoration
wsPaiement.Cells(ligneDest, "T").Value = wsAffichage.Cells(i, "L").Value * facteurMajoration
wsPaiement.Cells(ligneDest, "U").Value = wsAffichage.Cells(i, "M").Value * facteurMajoration
wsPaiement.Cells(ligneDest, "V").Value = wsAffichage.Cells(i, "N").Value * facteurMajoration
wsPaiement.Cells(ligneDest, 32).Value = wsPaiement.Cells(ligneDest, 18).Value * dureePeriodeMois
wsPaiement.Cells(ligneDest, 33).Value = wsPaiement.Cells(ligneDest, 19).Value * dureePeriodeMois
wsPaiement.Cells(ligneDest, 34).Value = wsPaiement.Cells(ligneDest, 20).Value * dureePeriodeMois
wsPaiement.Cells(ligneDest, 35).Value = wsPaiement.Cells(ligneDest, 21).Value * dureePeriodeMois
wsPaiement.Cells(ligneDest, 36).Value = wsPaiement.Cells(ligneDest, 22).Value * dureePeriodeMois
' ==============================================================================
' ====> INSÉREZ LE NOUVEAU BLOC DE CODE ICI <====
' ==============================================================================
' --- NOUVEAU : Ajout du Statut de Paiement ---
If j = 1 Then
' C'est la première échéance pour ce bénéficiaire
wsPaiement.Cells(ligneDest, "AM").Value = "NEXT"
Else
' C'est une échéance suivante
wsPaiement.Cells(ligneDest, "AM").Value = "NOT YET"
End If
' ==============================================================================
' ====> FIN DU NOUVEAU BLOC <====
' ==============================================================================
' On passe à la ligne de destination suivante
ligneDest = ligneDest + 1
Next j
End If
Next i
MsgBox "L'échéancier a été généré avec succès.", vbInformation, "Opération Terminée"
' --- 6. FINALISATION ---
Fin:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' NOUVEAU : Re-verrouiller la feuille dans tous les cas avant de quitter
If Not wsPaiement Is Nothing Then
wsPaiement.Protect Password:=MOT_DE_PASSE, AllowFiltering:=True ' AllowFiltering permet de garder les filtres actifs
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub ' On sort de la procédure proprement
ExitRoutine:
' --- REPROTECTION (se produit toujours, même après une erreur) ---
On Error Resume Next ' Si la feuille n'existe pas, on ignore l'erreur
If Not wsPaiement Is Nothing Then wsPaiement.Protect Password:=PW
Application.ScreenUpdating = True
Set wsAffichage = Nothing: Set wsPaiement = Nothing
Exit Sub
ErrorHandler:
MsgBox "Une erreur est survenue : " & vbCrLf & Err.Description, vbCritical, "Erreur d'insertion"
Resume ExitRoutine ' Saute à la section de nettoyage/reprotection
End Sub
' =========================================================================================
' FONCTION DE VÉRIFICATION
' Objectif: Vérifier que les totaux des baux en colonne C correspondent aux sommes
' des baux par bénéficiaire dans les colonnes I à M.
' Renvoie: True si tout est correct, False en cas d'erreur.
' =========================================================================================
' =========================================================================================
' FONCTION DE VÉRIFICATION
' Objectif: Vérifier que les totaux des baux en colonne C correspondent aux sommes
' des baux par bénéficiaire dans les colonnes I à M.
' Renvoie: True si tout est correct, False en cas d'erreur.
' =========================================================================================
Function VerifierCoherenceBaux() As Boolean
Dim wsAffichage As Worksheet
Dim sommeCalculee As Double
Dim valeurCellule As Double
Dim estCoherent As Boolean
Dim i As Long
estCoherent = True
Set wsAffichage = ThisWorkbook.Worksheets("AFFICHAGE & INSERTION")
For i = 0 To 4 ' Boucle pour les 5 vérifications (de C6/I à C10/M)
sommeCalculee = Application.WorksheetFunction.Sum(wsAffichage.Range(wsAffichage.Cells(3, 10 + i), wsAffichage.Cells(17, 10 + i)))
valeurCellule = wsAffichage.Cells(6 + i, "C").Value
If Round(sommeCalculee, 2) <> Round(valeurCellule, 2) Then
estCoherent = False
MsgBox "ERREUR DE COHÉRENCE !" & vbCrLf & vbCrLf & _
"Le total en " & wsAffichage.Cells(6 + i, "C").Address(False, False) & " (" & Format(valeurCellule, "#,##0.00") & ") " & _
"ne correspond PAS à la somme de la colonne " & Split(wsAffichage.Cells(1, 10 + i).Address, "$")(1) & " (" & Format(sommeCalculee, "#,##0.00") & ")." & vbCrLf & vbCrLf & _
"Veuillez corriger les montants avant de continuer.", _
vbCritical, "Vérification Échouée"
Exit For
End If
Next i
VerifierCoherenceBaux = estCoherent
End Function
' =========================================================================================
' FONCTION DE VÉRIFICATION
' Objectif: Vérifier que les totaux des baux en colonne C correspondent aux sommes
' des baux par bénéficiaire dans les colonnes I à M.
' Renvoie: True si tout est correct, False en cas d'erreur.
' =========================================================================================
Rechercher des sujets similaires à "code vba complexe suivi insertion modification"