Microsoft 365 Ecrire une formule de calcul en Vba Excel

N

NONO14

XLDnaute Impliqué
Bonjour à toutes et à tous,

Comment pourrait-on écrire cette formule de calcul en Vba, s'il vous plaît ? Pour le moment elle est écrite en dur dans des cellules Excel de mon tableau.
Cependant, il m'est demandé de l'écrire dans du code afin que personne ne puisse y accéder. Cette formule se trouve dans la colonne J du tableau de la feuille "Recap", il y en d'autres du même genre dans les colonnes K et L et un peu plus simples dans les colonnes M, N, O.
Bien sûr je pourrais protéger ces colonnes mais ce n'est pas ce qui m'est demandé, j'ai proposé cette solution, mais elle ne garantie pas une sécurité suffisante en cas d'effacement malencontreux par la personne qui va gérer ce fichier.
MAX_MAT et autres sont des Noms donnés à des cellules de la feuille "Données", soit les cellules L3 à O5.
Mot de passe de la feuille "falaise"
Merci par avance pour vos idées.
VB: 
=SI(A2="";"";SI(A2<>"";SI(ET(D2<>"";E2<>"");E2-D2;SI(ET(D2<>"";E2="";F2<>"");MAX_MAT-D2;SI(ET(D2<>"";E2="";ET(F2<>"";G2=""));"";SI(ET(D2<>"";E2="";F2="";G2="";H2="";I2<>"");MAX_MAT-D2;SI(ET(D2<>"";E2="";F2="";G2<>"");MAX_MAT-D2;SI(ET(D2<>"";E2="";ET(F2="";G2="");ET(H2="";I2<>""));I2-D2;SI(ET(D2<>"";E2="";F2="";G2="");MAX_MAT-D2;SI(D2="";""))))))))))
 

Pièces jointes

  • Tablo_Heures.xlsm
    282.8 KB · Affichages: 17
Dernière édition:
Solution
ChTi160
Bonjour le Fil
juste pour signaler qu'a ce Niveau il y a un problème !
VB: 
Private Sub TextCode_Change()
Dim Ctrl As Control
Dim Ctrl2 As Control
Dim Trouvé As Boolean
 Dim Trouve As Range

    Me.TextCode.Text = UCase(Me.TextCode) 'On met en Majuscule tout le Contenu du TextBox
    If Not EnableEvents Then Exit Sub
    Sheets("Liste_agents").Unprotect "falaise"
    'on cherche le nom associé au code dans la TS "t_Noms"
    With Sheets("Liste_agents").ListObjects("t_Noms")
    'ci-dessous on recherche dans une colonne ou se trouvent des Minuscules
    Set Trouve = .ListColumns(1).Range.Find(Me.TextCode, lookat:=xlWhol
Tu peux si la case n'a pas d'importance mettre Option Compare Text en tête de Module.
et supprimer ...
Trier par date Trier par votes
N

NONO14

XLDnaute Impliqué
vgendron à dit:
c'est normal,
un label est fait pour montrer une info.. il n'est pas destiné à entrer en interaction avec l'utilisateur:
pas de clic, pas de selection, pas de modification.==> ces évènements n'existent pas
Cliquez pour agrandir...
Je l'ai mis au niveau du TextCode_Change et ça fonctionne. En fait il ne reprend que les données déjà saisies, il ne fait pas de calcul immédiat.

Et bien non, il fait bien le calcul.
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
Décidemment c'est la journée des galères (vendredi 13).
J'ai mis en place ce code qui me permet d'injecter les données du formulaire UfPointage vers la feuille "Saisie" - TS t_Saisie.
Cependant, il m'ajoute une ligne plutôt que de continuer à remplir les lignes déjà saisies si le code employé existe déjà. J'ai dû zapper quelque chose. Je commence à fatiguer.
Voici le code :
VB: 
Private Sub Btx_Valide_Click()
Dim LastLine
Dim Ctrl As Control
  
    If Me.TextCode.Value = "" Then
        Me.Lbx_Information.Caption = "Merci de taper votre code"
    Exit Sub
    End If
    
   With Sheets("Saisie").ListObjects("t_Saisie")
   .ListRows.Add
   LastLine = .ListRows.Count
  
    .DataBodyRange(LastLine, 1) = Me.TextCode
    .DataBodyRange(LastLine, 2) = Me.Tbx_Noms
    .DataBodyRange(LastLine, 3) = Me.Txt_DateJour
    .DataBodyRange(LastLine, 4) = Me.Lbl_DebMat
    .DataBodyRange(LastLine, 5) = Me.Lbl_FinMat
    .DataBodyRange(LastLine, 6) = Me.Lbl_DebAPM
    .DataBodyRange(LastLine, 7) = Me.Lbl_FinAPM
    .DataBodyRange(LastLine, 8) = Me.Lbl_DebSoir
    .DataBodyRange(LastLine, 9) = Me.Lbl_FinSoir
    .DataBodyRange(LastLine, 10) = Me.Lbl_TotJour
    .DataBodyRange(LastLine, 11) = Me.Tbx_Commentaire
   End With
  
    For Each Ctrl In Frame2.Controls
        Select Case TypeName(Ctrl)
    Case "CheckBox"
Ctrl.Value = False
Ctrl.Enabled = True
Ctrl.Visible = True
    Case "Label"
Ctrl.Caption = ""
        End Select
Next Ctrl

Me.TextCode.Value = ""
Me.Tbx_Noms.Value = ""
Me.Tbx_Commentaire.Value = ""

Me.Lbx_Information.Caption = "Veuillez saisir votre code employé(e)"

End Sub
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
c'est normal.. à aucun moment tu ne regardes si la ligne existe déjà
il faudrait modifier pour avoir ca
VB: 
with sheets("Saisie").listobjects("t_saisie")
    chercher ligne (un truc du genre set trouve=....)
    si not trouve is nothing then 'la ligne existe, il faut la compléter
       Ligne=trouve.row -.range.row
   sinon ' il s'agit d'une nouvelle ligne
      ligne=.listrows.add.index ' on ajoute une ligne et on note directement son index
   fin si
  
'on peut remplir la ligne
   .databodyrange(ligne,1)=...
...

end with
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
vgendron à dit:
c'est normal.. à aucun moment tu ne regardes si la ligne existe déjà
il faudrait modifier pour avoir ca
VB: 
with sheets("Saisie").listobjects("t_saisie")
    chercher ligne (un truc du genre set trouve=....)
    si not trouve is nothing then 'la ligne existe, il faut la compléter
       Ligne=trouve.row -.range.row
   sinon ' il s'agit d'une nouvelle ligne
      ligne=.listrows.add.index ' on ajoute une ligne et on note directement son index
   fin si
 
'on peut remplir la ligne
   .databodyrange(ligne,1)=...
...

end with
Cliquez pour agrandir...
Oui c'est exact, c'est ce que j'étais entrain de me rendre compte. J'ai copié bêtement un code que j'avais sous le coude et voilà le résultat, quel tebé je suis.
Allez, je m'y remets.
Merci pour tes explications.
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
vgendron à dit:
attention... une ligne qui existe déjà, c'est une ligne avec le meme NOM que celui sélectionné ET la même date du jour


ex: on est le 13/09, Paul Ochon fait sa saisie..
pas question de modifier la ligne de Paul Ochon du 11/09...
Cliquez pour agrandir...
Oui c'est exact, il va donc falloir faire la recherche sur la date et sur le code agent, ça ce complique là.
Normalement, le tableau devrait être vidé tous les soirs, mais on ne sait jamais en cas d'oubli, il faut être prévoyant.
Merci de m'avoir interpellé sur ça.
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
Il faudrait quelque chose comme ça mais avec 2 critères de recherche
VB: 
    With Sheets("Saisie").ListObjects("t_Saisie")
        Set trouve = .ListColumns("Code agent").Range.Find(Me.TextCode, lookat:=xlWhole)
        If Not trouve Is Nothing Then
            Me.Tbx_Noms = trouve.Offset(0, 1)
        End If
    End With
Else
    With Sheets("Saisie").ListObjects("t_Saisie")
        Set trouve = .ListColumns("Code agent").Range.Find(Me.TextCode, lookat:=xlWhole)
        If Not trouve Is Nothing Then
            Me.Lbl_DebMat.Caption = Format(trouve.Offset(0, 3), "hh:mm")
            Me.Lbl_FinMat.Caption = Format(trouve.Offset(0, 4), "hh:mm")
            Me.Lbl_DebAPM.Caption = Format(trouve.Offset(0, 5), "hh:mm")
            Me.Lbl_FinAPM.Caption = Format(trouve.Offset(0, 6), "hh:mm")
            Me.Lbl_DebSoir.Caption = Format(trouve.Offset(0, 7), "hh:mm")
            Me.Lbl_FinSoir.Caption = Format(trouve.Offset(0, 8), "hh:mm")
            Me.Lbl_TotJour.Caption = Format(trouve.Offset(0, 9), "hh:mm")
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
Voilà j'ai essayé de faire ce code mais j'ai une incompatibilité de type sur la ligne :
"Set cellulecherchee = .ListColumns("Code agent") And .ListColumns("Date").DataBodyRange.Find(Me.TextCode.Value And Me.Txt_DateJour.Value, lookat:=xlWhole)"
Je n'arrive pas à trouver mon erreur.
Avez-vous une idée ?
Merci par avance
VB: 
Private Sub Btx_Valide_Click()
Dim LastLine
Dim Ctrl As Control
Dim cellulecherchee As Range, ligne As Long, col As Long, valeur_cherchee As String
    
    If Me.TextCode.Value = "" Then
        Me.Lbx_Information.Caption = "Merci de taper votre code"
    Exit Sub
    End If
    
valeur_cherchee = Me.TextCode & Me.Txt_DateJour
    
    With Sheets("Saisie").ListObjects("t_Saisie")
    Set cellulecherchee = .ListColumns("Code agent") And .ListColumns("Date").DataBodyRange.Find(Me.TextCode.Value And Me.Txt_DateJour.Value, lookat:=xlWhole)

    If cellulecherchee Is Nothing Then
    .DataBodyRange(LastLine, 1) = Me.TextCode
    .DataBodyRange(LastLine, 2) = Me.Tbx_Noms
    .DataBodyRange(LastLine, 3) = Me.Txt_DateJour
    .DataBodyRange(LastLine, 4) = Me.Lbl_DebMat
    .DataBodyRange(LastLine, 5) = Me.Lbl_FinMat
    .DataBodyRange(LastLine, 6) = Me.Lbl_DebAPM
    .DataBodyRange(LastLine, 7) = Me.Lbl_FinAPM
    .DataBodyRange(LastLine, 8) = Me.Lbl_DebSoir
    .DataBodyRange(LastLine, 9) = Me.Lbl_FinSoir
    .DataBodyRange(LastLine, 10) = Me.Lbl_TotJour
    .DataBodyRange(LastLine, 11) = Me.Tbx_Commentaire
  
Else
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
non non.. c'est pas du tout comme ca qu'il faut s'y prendre
quand tu fais
set trouve=.range.find("cequoncherche",lookat:=xlwhole)
vba se charge de parcourir la range pour trouver "cequoncherche" et il te renvoie la cellule (c'est une range) dans trouve.. c'est pour ca que trouve est défini as range

la;. on a besoin de comparer DEUX colonnes à DEUX critères différents: le nom et la date
il faut donc parcourir "a la main" les lignes du tableau

VB: 
With Sheets("Saisie").ListObjects("t_Saisie")
    Trouvé=false
    for i=1 to .listrows.count 'pour chaque ligne de la table
     if .ListColumns("Code agent").databodyrange(i)=Me.TextCode And .ListColumns("Date").DataBodyRange(i)=me.txt_DateJour then
            ligne=i
            Trouvé=true
            exit for
    end if
    if Not Trouvé then 'on a pas trouvé de ligne correspondante ==> il faut donc créer une nouvelle ligne
       ligne=.listrows.add.index 'on créé une nouvelle ligne et on note son index'
    end if
    
    'ici on sait où écrire les infos
        
    
    .DataBodyRange(ligne, 1) = Me.TextCode
    .DataBodyRange(ligne, 2) = Me.Tbx_Noms
    .DataBodyRange(ligne, 3) = Me.Txt_DateJour
    .DataBodyRange(ligne, 4) = Me.Lbl_DebMat
    .DataBodyRange(ligne, 5) = Me.Lbl_FinMat
    .DataBodyRange(ligne, 6) = Me.Lbl_DebAPM
    .DataBodyRange(ligne, 7) = Me.Lbl_FinAPM
    .DataBodyRange(ligne, 8) = Me.Lbl_DebSoir
    .DataBodyRange(ligne, 9) = Me.Lbl_FinSoir
    .DataBodyRange(ligne, 10) = Me.Lbl_TotJour
    .DataBodyRange(ligne, 11) = Me.Tbx_Commentaire
 end with
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
Voici mon code complet. J'ai un message d'erreur "End With sans With" au niveau du End With.
Je suis vraiment désolé de ne pas trouver. Je vais reprendre demain à tête reposée.
Je termine une bricole et on verra plus tard.
Toutes mes excuses.

VB: 
Private Sub Btx_Valide_Click()
Dim Ctrl As Control
    
    If Me.TextCode.Value = "" Then
        Me.Lbx_Information.Caption = "Merci de taper votre code"
    Exit Sub
    End If

With Sheets("Saisie").ListObjects("t_Saisie")
    Trouvé = False
    For I = 1 To .ListRows.Count 'pour chaque ligne de la table
     If .ListColumns("Code agent").DataBodyRange(I) = Me.TextCode And .ListColumns("Date").DataBodyRange(I) = Me.Txt_DateJour Then
            ligne = I
            Trouvé = True
            Exit For
    End If
    If Not Trouvé Then 'on a pas trouvé de ligne correspondante ==> il faut donc créer une nouvelle ligne
       ligne = .ListRows.Add.Index 'on créé une nouvelle ligne et on note son index'
    
    'ici on sait où écrire les infos
        
    
    .DataBodyRange(ligne, 1) = Me.TextCode
    .DataBodyRange(ligne, 2) = Me.Tbx_Noms
    .DataBodyRange(ligne, 3) = Me.Txt_DateJour
    .DataBodyRange(ligne, 4) = Me.Lbl_DebMat
    .DataBodyRange(ligne, 5) = Me.Lbl_FinMat
    .DataBodyRange(ligne, 6) = Me.Lbl_DebAPM
    .DataBodyRange(ligne, 7) = Me.Lbl_FinAPM
    .DataBodyRange(ligne, 8) = Me.Lbl_DebSoir
    .DataBodyRange(ligne, 9) = Me.Lbl_FinSoir
    .DataBodyRange(ligne, 10) = Me.Lbl_TotJour
    .DataBodyRange(ligne, 11) = Me.Tbx_Commentaire
 End With
  End If
    
    For Each Ctrl In Frame2.Controls
        Select Case TypeName(Ctrl)
    Case "CheckBox"
Ctrl.Value = False
Ctrl.Enabled = True
Ctrl.Visible = True
    Case "Label"
Ctrl.Caption = ""
        End Select
Next Ctrl

Me.TextCode.Value = ""
Me.Tbx_Noms.Value = ""
Me.Tbx_Commentaire.Value = ""

Me.Lbx_Information.Caption = "Veuillez saisir votre code employé(e)"

End Sub
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
il faut fermer les boucles et conditions au bon endroit
pour ne rien manquer.. astreints toi à utiliser l'indentation du code (décalage avec des tabulations)
c'est plus facile pour se repérer
VB: 
Private Sub Btx_Valide_Click()

Dim Ctrl As Control

    If Me.TextCode.Value = "" Then
        me.Lbx_Information.Caption = "Merci de taper votre code"
        Exit Sub
    End If



With Sheets("Saisie").ListObjects("t_Saisie")
    Trouvé = False
    For I = 1 To .ListRows.Count 'pour chaque ligne de la table
       If .ListColumns("Code agent").DataBodyRange(I) = Me.TextCode And .ListColumns("Date").DataBodyRange(I) = Me.Txt_DateJour Then
            ligne = I
            Trouvé = True
            Exit For
        End If
    Next i
    If Not Trouvé Then 'on a pas trouvé de ligne correspondante ==> il faut donc créer une nouvelle ligne
       ligne = .ListRows.Add.Index 'on créé une nouvelle ligne et on note son index'
     end if
 
    'ici on sait où écrire les infos
    .DataBodyRange(ligne, 1) = Me.TextCode
    .DataBodyRange(ligne, 2) = Me.Tbx_Noms
    .DataBodyRange(ligne, 3) = Me.Txt_DateJour
    .DataBodyRange(ligne, 4) = Me.Lbl_DebMat
    .DataBodyRange(ligne, 5) = Me.Lbl_FinMat
    .DataBodyRange(ligne, 6) = Me.Lbl_DebAPM
    .DataBodyRange(ligne, 7) = Me.Lbl_FinAPM
    .DataBodyRange(ligne, 8) = Me.Lbl_DebSoir
    .DataBodyRange(ligne, 9) = Me.Lbl_FinSoir
    .DataBodyRange(ligne, 10) = Me.Lbl_TotJour
    .DataBodyRange(ligne, 11) = Me.Tbx_Commentaire
 End With

    For Each Ctrl In Frame2.Controls
        Select Case TypeName(Ctrl)
            Case "CheckBox"
                Ctrl.Value = False
                Ctrl.Enabled = True
                Ctrl.Visible = True
            Case "Label"
                Ctrl.Caption = ""
        End Select
    Next Ctrl
Me.TextCode.Value = ""
Me.Tbx_Noms.Value = ""
Me.Tbx_Commentaire.Value = ""
Me.Lbx_Information.Caption = "Veuillez saisir votre code employé(e)"

End Sub
 
Vote positif 0 Vote négatif
TooFatBoy

TooFatBoy

XLDnaute Barbatruc
NONO14 à dit:
J'ai un message d'erreur "End With sans With" au niveau du End With.
Cliquez pour agrandir...
D'où l'intérêt de l'indentation du code : ça permet de voir d'un coup d'œil s'il y a un problème de "boucle".

Le Next doit être sous le For, le End With sous le With, le Loop sous le Do, etc.
Et ce qui est à l'intérieur doit être décalé vers la droite.

Ainsi, si en dessous du With tu n'as pas ton End With, tu vois tout de suite qu'il y a un problème. ;)
 
Vote positif 0 Vote négatif
N

NONO14

XLDnaute Impliqué
Bonjour à toutes et à tous,
Je me suis remis sur mon projet et j'ai modifié quelques actions qui ne convenaient pas. J'ai remplacé tous labels de saisie d'heure par des TextBoxs ce qui sera plus facile pour le calcul du total d'heures jour, avec les Labels ça beuguait.
Cependant j'ai un message d'erreur dans le code suivant, j'ai certainement dû mal corrigé le code selon les modifications. "Objet spécifié introuvable". Cette erreur survient dés que je tape le code de l'employé (FAL221).
Sur cette ligne de code : " Me.Frame2.Controls("Chk_" & Nom).Enabled = (Ctrl.Value = "")"
Je n'arrive pas à trouver mon erreur.
Pouvez-vous m'aider s'il vous plait ?
Je vous en remercie par avance

VB: 
Private Sub TextCode_Change()
Dim CtrlOb As Control
    With Sheets("Liste agents").ListObjects("t_Noms")
        Set trouve = .ListColumns("Code").Range.Find(Me.TextCode, lookat:=xlWhole)
        If Not trouve Is Nothing Then
            Me.Tbx_Noms = trouve.Offset(0, 1)
        End If
    End With
   
    With Sheets("Saisie").ListObjects("t_Saisie")
        Set trouve = .ListColumns("Code agent").Range.Find(Me.TextCode, lookat:=xlWhole)
        If Not trouve Is Nothing Then
            Me.Tbx_DebMat.Value = Format(trouve.Offset(0, 3), "hh:mm")
            Me.Tbx_FinMat.Value = Format(trouve.Offset(0, 4), "hh:mm")
            Me.Tbx_DebAPM.Value = Format(trouve.Offset(0, 5), "hh:mm")
            Me.Tbx_FinAPM.Value = Format(trouve.Offset(0, 6), "hh:mm")
            Me.Tbx_DebSoir.Value = Format(trouve.Offset(0, 7), "hh:mm")
            Me.Tbx_FinSoir.Value = Format(trouve.Offset(0, 8), "hh:mm")
            Me.Tbx_Commentaire = trouve.Offset(0, 9)
         
            For Each Ctrl In Me.Frame2.Controls
                If TypeName(Ctrl) = "TextBox" Then
                    Nom = Replace(Ctrl.Name, "Tbx_", "")
                    If Nom <> "Tbx_DateJour" Then
                        Ctrl.Enabled = (Ctrl.Value = "")
                        Me.Frame2.Controls("Chk_" & Nom).Enabled = (Ctrl.Value = "")
                        Me.Frame2.Controls("Chk_" & Nom).Visible = (Ctrl.Value = "")
                    End If
                End If
            Next Ctrl
         
        End If
    End With
End Sub
 

Pièces jointes

  • PointHeure5.xlsm
    751.3 KB · Affichages: 1
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
Microsoft 365 Formule si est vide
Réponses
9
Affichages
474
Marvin57
M
F
  • Résolu(e)
XL 2013 Resultat en fonction de 3 conditions cumultatives
Réponses
2
Affichages
374
franxy
F
M
  • Question
XL 2019 Recherche d'un mot dans une chaîne de caractère depuis une plage de références puis si présent renvoyer la référence
Réponses
7
Affichages
513
MilieBZH
M
HamoudaBA
  • Question
XL 2021 RESOLU recherchev vba sur autre feuille
Réponses
10
Affichages
822
HamoudaBA
HamoudaBA
C
  • Question
Microsoft 365 Formule Excel qui additionne la tarification quotidienne
Réponses
2
Affichages
201
TooFatBoy
TooFatBoy
D
  • Question
Microsoft 365 Excel fonction SI
Réponses
5
Affichages
434
dede869
D
M
  • Résolu(e)
XL 2013 Calcul des heures travaillées de jour, de nuit et plus de 24h consécutives
2 3
Réponses
41
Affichages
2 K
Manutela
M
M
  • Question
Microsoft 365 "Vous avez un nombre trop important d'arguments pour cette fonction"
Réponses
11
Affichages
470
TooFatBoy
TooFatBoy
F
  • Résolu(e)
Microsoft 365 comptage de cellules
Réponses
3
Affichages
262
FRB78
F
D
  • Résolu(e)
Microsoft 365 Copier / coller données spécifiques documents txt vers Excel
Réponses
3
Affichages
580
Staple1600
Staple1600

Membres actuellement en ligne

4 membres et 31 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 134
Messages
2 116 613
Membres
112 811
dernier inscrit
shade1452