XL 2016 Calculs à partir date Textbox pour affichage autres Textbox

Grall

XLDnaute Nouveau
Bonjour à toutes et tous,

J'ai un soucis car je n'arrive pas à résoudre un problème de calcul.

J'ai une userform avec des Textbox, pour certaines modifiables et d'autres juste pour affichage de dates d'échéances.

J'ai deux types de calcul:
- un calcul par rapport à une date d'une Textbox avec -50 jours et -70 jours pour prise en compte dans un tableau, puis affichage dans deux Textbox de l'userform
- un calcul par rapport à la même Tetxbox avec 6 mois - 1 jour, puis 3 mois + 1 jour, avec prise en compte dans le même tableau puis affichage dans deux autres Textbox de la même userform

Je voudrais faire le calcul par Vba afin d'éviter la modification des formules des calculs du tableau si cela est réalisable. Mon soucis est principalement les calculs avec des mois moins des jours.

Merci par avance.
 

Pièces jointes

  • Explication.pdf
    81.8 KB · Affichages: 28
Dernière édition:
Solution
Bonjour,
Sans réellement comprendre ce que vous souhaitez, dans le code ci-dessous, si vous initialisez "Case rng.Rows.Count = 1 " à 4 ça ne règle pas votre problème ?

VB:
Private Sub RemoveRecord(ByVal RecordNumber As Long)
 
 'ActiveSheet.Unprotect ' enlève la protection et mettre le mot de passe entre "_"
 
 ' Suppression de l'enregistrement
 ' Contrainte : il doit rester un enregistrement
 
 Select Case True
 
  Case rng.Rows.Count = 1 ' Reste 1 enregistrement
    MsgBox "Vous devez laisser un enregistrement", vbInformation, "Suppression impossible"
 
  Case MsgBox("Voulez-vous supprimer la ligne sélectionnée", _
            vbCritical + vbYesNo + vbDefaultButton2, _
            "Suppression de la ligne " & CurrentRecord + 1) =...

dg62

XLDnaute Barbatruc
Bonjour Grall

Beau document mais d'aucune utilité pour bâtir le code.
Pas les noms des textbox, pas de références pour le tableau...
Il est préférable de joindre un fichier xls avec votre tableau et le userform pour avoir une solution.

Et en VBA vous pouvez vous inspirer de ce lien https://docs.microsoft.com/fr-fr/office/vba/language/reference/user-interface-help/dateadd-function

Exemple de code

VB:
Sub essai_Date()

Dim dateref1, dateRef2 As Date    ' Declare variables.
Dim IntervalType As String 'm pour ajouter des mois y pour des jours
Dim Nombre_Ajout As Integer 'nombre de mois ou de jour à ajouter à la date de référence

dateref1 = Range("A1").Value 'date début des congés


IntervalType = "m" ' Ajout de mois
Nombre_Ajout = 6      ' 6 mois
Range("B1").Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) - 1 ' 6 mois - 1 jour

Nombre_Ajout = 3 'Ajout de 3 mois
Range("C1").Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) + 1  ' 3 mois + 1 jour

dateRef2 = Range("B1").Value  ' date fin des congés
IntervalType = "y" ' Ajout ou retrait de jours
Nombre_Ajout = -70 ' - 70 jours
Range("D1").Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'fin de congés - 70 jours

Nombre_Ajout = -50  ' - 50 jours
Range("E1").Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'Fin de congés - 50 jours

End Sub
 

Pièces jointes

  • calcul date.xlsx
    8.5 KB · Affichages: 33
Dernière édition:

Grall

XLDnaute Nouveau
bonjour,

Merci pour la réponse rapide, je verrais cela demain car je dois partir.

J'avais pris les mêmes formules avec une condition si la date est vide.
=SI(ESTVIDE(L3);" ";MOIS.DECALER(L3;6)-1) représente M3 pour les autres calculs en -70 et -50
=SI(ESTVIDE(L3);" ";MOIS.DECALER(L3;3)+1)
=SI(M3=" ";" ";M3-70)
=SI(M3=" ";" ";M3-50)

Je ferais aussi un fichier Excel avec le masque de saisie et le VBA en question pour que vous puissiez voir l'ensemble.

Encore un grand merci.
 

Grall

XLDnaute Nouveau
Merci,

Aucun soucis pour le code, cela marche. J'ai juste fait les modifications par rapport au value des textbox.

Le code:
"Private Sub WriteRecord(ByVal RecordNumber As Long)

Dim dateref1, dateRef2 As Date ' Declare variables.
Dim IntervalType As String 'm pour ajouter des mois y pour des jours
Dim Nombre_Ajout As Integer 'nombre de mois ou de jour à ajouter à la date de référence

dateref1 = txtDebutConge.Value 'date début des congés

IntervalType = "m" ' Ajout de mois
Nombre_Ajout = 6 ' 6 mois
txtfinConge.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) - 1 ' 6 mois - 1 jour

Nombre_Ajout = 3 'Ajout de 3 mois
txtConPatient.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) + 1 ' 3 mois + 1 jour

dateRef2 = txtfinConge.Value ' date fin des congés

IntervalType = "y" ' Ajout ou retrait de jours
Nombre_Ajout = -70 ' - 70 jours
txtRdvAmAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'fin de congés - 70 jours

Nombre_Ajout = -50 ' - 50 jours
txtRdvHiaAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'Fin de congés - 50 jours

' Ecriture de l'enregistrement
Me.cboMember.ListIndex = -1
RecordNumber = RecordNumber + 1

With rng

With .Cells(RecordNumber, 1)
If Len(.Value) = 0 Then ' ID
' .Value = Application.WorksheetFunction.Max(rng.Columns(1)) + 1
End If
'.NumberFormat = "\R000" ' Format

'impose saisie Nom
If Me.txtName.Value = "" Then
MsgBox "Vous devez saisir une Nom !"
Me.txtName.SetFocus
Exit Sub
End If

'impose saisie Prénom
If Me.txtFirstName.Value = "" Then
MsgBox "Vous devez saisir un prénom !"
Me.txtFirstName.SetFocus
Exit Sub
End If

'impose saisie Identifiant
If Me.txtId.Value = "" Then
MsgBox "Vous devez saisir un Identifiant !"
Me.txtId.SetFocus
Exit Sub
End If

End With
.Cells(RecordNumber, 1) = Me.txtGrade
.Cells(RecordNumber, 2) = Me.txtName
.Cells(RecordNumber, 3) = Me.txtFirstName
.Cells(RecordNumber, 4) = Me.txtDateNaissance
.Cells(RecordNumber, 5) = Me.txtAppartenance
.Cells(RecordNumber, 6) = Me.txtArs
.Cells(RecordNumber, 7) = Me.txtId
.Cells(RecordNumber, 8) = Me.txtRecpLivAnt
.Cells(RecordNumber, 9) = Me.txtOrganismeGestion
.Cells(RecordNumber, 10) = Me.cboTypeConge
.Cells(RecordNumber, 11) = Me.cboPeriode
.Cells(RecordNumber, 12) = Me.txtDebutConge
.Cells(RecordNumber, 13) = Me.txtfinConge
.Cells(RecordNumber, 14) = Me.txtConPatient
.Cells(RecordNumber, 15) = Me.txtRdvAmAvant
.Cells(RecordNumber, 16) = Me.txtRdvHiaAvant
.Cells(RecordNumber, 17) = Me.txtRdvAntenne
.Cells(RecordNumber, 18) = Me.txtRdvHia
.Cells(RecordNumber, 19) = Me.cboTypologieBlessures
.Cells(RecordNumber, 20) = Me.cboAT
.Cells(RecordNumber, 21) = Me.txtEnvOG & "-" & Me.txtMsgOrgaGest
.Cells(RecordNumber, 22) = Me.txtEnvOG
.Cells(RecordNumber, 23) = Me.txtMsgOrgaGest
.Cells(RecordNumber, 24) = Me.txtEnvIRASS
.Cells(RecordNumber, 25) = Me.txtAdresse & "-" & Me.txtVille & "-" & Me.txtCP & "-" & Me.txtTelephone
.Cells(RecordNumber, 26) = Me.txtAdresse
.Cells(RecordNumber, 27) = Me.txtVille
.Cells(RecordNumber, 28) = Me.txtCP
.Cells(RecordNumber, 29) = Me.txtTelephone
.Cells(RecordNumber, 30) = Me.txtObservation

End With

Me.cboMember.ListIndex = CurrentRecord

End Sub"


Par contre, je me pose la question si une condition pour une non saisie de la Textbox qui sert à dateref1 peut être utile ?
En général, les dossiers comportent une date de début mais il arrive que cette date ne figure pas ce qui implique un bug.
 

Grall

XLDnaute Nouveau
Merci,

J'avais bien vue le problème, mais suite contact avec le responsable, pour lui la possibilité d'une non saisie doit être possible. Ce qui me semble pas logique !

Je pense partir sur un contrôle d'une date, si saisie les calculs se feront et sinon, un message de confirmation et je passe les calculs.

De type If , Else et End If
 
Dernière édition:

Grall

XLDnaute Nouveau
Bonsoir,

La modification sur la partie du code:
"
If dateref1 = "" Then 'prise en compte d'une non saisie de date de Début de congé

txtfinConge.Value = "" 'textbox vide
txtConPatient.Value = "" 'idem
txtRdvAmAvant.Value = "" 'idem
txtRdvHiaAvant.Value = "" 'idem

Else

dateref1 = txtDebutConge.Value 'date début des congés

IntervalType = "m" ' Ajout de mois
Nombre_Ajout = 6 ' 6 mois
txtfinConge.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) - 1 ' 6 mois - 1 jour

Nombre_Ajout = 3 'Ajout de 3 mois
txtConPatient.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) + 1 ' 3 mois + 1 jour

dateRef2 = txtfinConge.Value ' date fin des congés

IntervalType = "y" ' Ajout ou retrait de jours
Nombre_Ajout = -70 ' - 70 jours
txtRdvAmAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'fin de congés - 70 jours

Nombre_Ajout = -50 ' - 50 jours
txtRdvHiaAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'Fin de congés - 50 jours

End If
"


Je ne pense pas avoir de problème maintenant.

Merci encore
 

Grall

XLDnaute Nouveau
Bonjour,

Ce matin bug car non prise en compte des calculs dans les TextBox ?
Je ne comprends pas car hier aucun soucis après enregistrement et fermeture puis réouverture.

Par contre, lors de la saisie je n'ai plus la mise en forme de la ligne ?

J'essai de relire le code pour voir mais aucune idée de la source d'erreur.

Le fichier en pièce jointe.

Merci de votre aide.
 

Pièces jointes

  • Tableau Patients.xlsm
    100.8 KB · Affichages: 8

dg62

XLDnaute Barbatruc
Bonjour,
A priori vous n'affectez pas les calculs aux textbox
VB:
Private Sub txtdebutConge_Change()
Dim dateref1, dateRef2 As Date    ' Declare variables.
Dim IntervalType As String 'm pour ajouter des mois y pour des jours
Dim Nombre_Ajout As Integer 'nombre de mois ou de jour à ajouter à la date de référence
IntervalType = "m" ' Ajout de mois
            Nombre_Ajout = 6      ' 6 mois
            txtfinConge.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) - 1 ' 6 mois - 1 jour

End Sub
 
Dernière édition:

Grall

XLDnaute Nouveau
bonjour,

J'ai un problème pour l'affectation avec le usf calendar qui me renvoir un format d/mm/yyyy ?
Avant, pas de soucis et cela bloque l'affectation ou alors j'ai pas compris.

J'ai ajouter la ligne de code en modifiant, au dessus, afin de prendre en compte le format:
"Dim l As Integer

'ActiveSheet.Unprotect ' enlève la protection et mettre le mot de passe entre "_"

If MsgBox("confirmer l'insertion du contact", vbYesNo, "demande de confirmation d'ajout") = vbYes Then 'affichage message de confirmation"
l = Sheets("AM").Range("a500").End(xlUp).Row + 1 'place a la ligne 500 et remonte jusqu'a la premiére ligne vide du tableau'
Range("A" & l - 1 & ":AD" & l - 1).Copy
Range("A" & l & ":AD" & l).PasteSpecial xlFormats
Application.CutCopyMode = False 'effacer le mode copy de la feuille

End If"

Pas de soucis, mais depuis la date sur la saisie de la txtbox => txtDebutConge systématiquement prends la forme 1/01/2020 jusqu'a 9/01/2020 et idem pour les mois suivant.

Même avec une définition de format ?

J'ai pas affecté correctement ou alors il faut que je conditionne le format pour toutes les textbox en format date ?

Merci par avance.
 

Grall

XLDnaute Nouveau
Suite modification et vérification, j'ai repris l'affectation des textbox.
La recopie est bien prise en compte dans la feuille.

Par contre, les calculs sont faux ? Affichage systématique des même valeurs dans 4 textbox ?
Sans doute un format date, mais je sèche ?

Merci
 

Pièces jointes

  • Tableau Patients.xlsm
    114.3 KB · Affichages: 25

dg62

XLDnaute Barbatruc
bonjour,

Dateref1 n'est pas affecté
Supprimer tous les TXtdebut, fin... .change ils sont inutiles les calculs sont conditionnés par la date.
Ajoutez cette procédure après l'affectation de la date à Txtdébutconge.

VB:
'calcul des dates
Dim dateref1, dateRef2 As Date    ' Declare variables.
Dim IntervalType As String 'm pour ajouter des mois y pour des jours
Dim Nombre_Ajout As Integer 'nombre de mois ou de jour à ajouter à la date de référence
dateref1 = CDate(txtDebutConge.Value)
IntervalType = "m" ' Ajout de mois

            Nombre_Ajout = 6      ' 6 mois
            txtfinConge.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) - 1 ' 6 mois - 1 jour
         
            Nombre_Ajout = 3 'Ajout de 3 mois
            txtConPatient.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) + 1  ' 3 mois + 1 jour

dateRef2 = txtfinConge.Value
IntervalType = "y" ' Ajout ou retrait de jours
         
            Nombre_Ajout = -70 ' - 70 jours
            txtRdvAmAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'fin de congés - 70 jours

            Nombre_Ajout = -50  ' - 50 jours
            txtRdvHiaAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'Fin de congés - 50 jours

A placer dans cette procédure

Code:
Private Sub btnDebutConge_Click()


Dim dateref1, dateRef2 As Date    ' Declare variables.
Dim IntervalType As String 'm pour ajouter des mois y pour des jours
Dim Nombre_Ajout As Integer 'nombre de mois ou de jour à ajouter à la date de référence

Call Calendar.SelectedDate(Me.txtDebutConge)
'Calcul des dates
dateref1 = CDate(txtDebutConge.Value)
IntervalType = "m" ' Ajout de mois

            Nombre_Ajout = 6      ' 6 mois
            txtfinConge.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) - 1 ' 6 mois - 1 jour
          
            Nombre_Ajout = 3 'Ajout de 3 mois
            txtConPatient.Value = DateAdd(IntervalType, Nombre_Ajout, dateref1) + 1  ' 3 mois + 1 jour

dateRef2 = txtfinConge.Value
IntervalType = "y" ' Ajout ou retrait de jours
          
            Nombre_Ajout = -70 ' - 70 jours
            txtRdvAmAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'fin de congés - 70 jours

            Nombre_Ajout = -50  ' - 50 jours
            txtRdvHiaAvant.Value = DateAdd(IntervalType, Nombre_Ajout, dateRef2) 'Fin de congés - 50 jours


End Sub


Autre remarque si rien n'est saisi dans l'usf l’enregistrement se fait quand même et insertion d'une ligne vide dans la feuille.

Pour rendre la saisie du nom obligatoire

VB:
Private Sub TXTName_Exit(ByVal cancel As MSForms.ReturnBoolean)
    If txtName = "" Then
        MsgBox ("Saisie du nom obligatoire")
        cancel = True
    End If
End Sub
 
Dernière édition:

Grall

XLDnaute Nouveau
Bonsoir,

Merci pour la solution, je n'avais pas penser au calendar.

Par contre, je dois refaire le code pour la reprise du champ txtDebutconge pour la prise en compte du non remplissage de celle-ci.

Ma solution ne marche plus avec le dateRef1 ="". je vais essayer demain avec une value par défaut pour voir ?

J'ai repris le code pour la textBox du Nom vide et je ferais l'adaptation pour le Nom, Prénom et identfiant secu afin d'éviter les homonymes.
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof