Code VBA pour additionner les heures supérieures à 24

Le 31/08/2016 à 13:16

Bonjour à tous,

après avoir beaucoup cherché sur les forums, je ne suis pas arrivé à trouver un code pour calculer les heures supérieures à 24.

Je sais le faire sur une feuille excel mais pas en passant par un code VBA.

Exemple :

textbox TB2 : heure de début du travail

texbox TB3 : heure de fin du travail

Texbox TB4 : calcul automatique dès que l'heure de fin est inscrite.

checkBox TB5 : choix d'une journée de travail de 3h (par défaut le formulaire indique 8h00), ce choix s'inscrit dans la texbox TB6

texbox TB20 : heures supplémentaires déjà cumulées (le solde s'affiche par userform initialize)

commandbutton CALCUL :

  • Il calcul les heures supplémentaires du jour (TB4-TB6). Ces heures sup (en positif ou négatif) s'inscrivent en TB 21
  • et calcul les heures supplémentaires nouvellement cumulées (TB20+TB21)
Quel code indiquer pour que les heures supplémentaire indiquent plus de 24 ?

Ci joint un petit fichier simplifié !

Merci pour votre aide,

Seb

130heures-sup-a-24.xlsm (27.98 Ko)
Le 31/08/2016 à 16:32

Bonjour,

Un exemple pour te donner une piste :

Sub Test2()

    'en format texte
    Dim Heure1 As Date
    Dim Heure2 As Date
    Dim TotalHeure As Date

    'en format nombre
'    Dim Heure1 As Single
'    Dim Heure2 As Single
'    Dim TotalHeure As Single

    Heure1 = CDate("15:30:00")
    Heure2 = CDate("21:15:00")

'    Heure1 = 0.6458333
'    Heure2 = 0.8854167

    TotalHeure = Heure1 + Heure2 'soit 1.53125 au format nombre, soit 31/12/1899 12:45:00 au format texte (ce qui ne veux rien dire !)

    'formatage avec la fonction Text pour un affichage plus compréhensible
    MsgBox Application.Text(TotalHeure, "[h]:mm") 'les crochets indiquent que les heures sont susceptibles d'être supérieures à 24

End Sub

Petit rappel, pour Excel, l'unité (1) représente 1 jour donc, 1/24 représente 1 heure

Le 31/08/2016 à 18:00

Bonjour Seb25 et le forum,

Encore un autre post. Le 3ème du genre.

Je t'avais proposé une solution avec le cumul des heures supp en page RECAP, mais effectivement le dépassement de 24h n'était pas pris en compte.

Dans le tableau RECAP, j'ai repris la formule de Theze

=TEXTE(SI(B3>0;B3/24;ABS(B3/24));"[h]:mm")

et ça marche.

Voici le fichier en P.J. à adapter

cdt

Henri

175seb25-essai-24h.xlsm (30.88 Ko)
Le 31/08/2016 à 20:39

Merci à vous deux. Je me penche sur vos solutions, en sachant que je souhaite passer par un USF et pas par une fonction dans une feuille excel. Je vais en comprendre la logique et vous tient informé.

A très vite,

seb

Le 01/09/2016 à 07:04

Bonjour,

Comme précisé dans mon post, pour Excel, les heures sont des nombres avec décimales (ou non) et l'addition de temps c'est de l'addition de nombre, 1,5 représente 36 heures c'est seulement le formatage qui nous permet de mieux l'interpréter. Le problème avec la fonction Text() c'est qu'elle n'accepte pas les valeurs négatives !

Re,

Pour ça, il te faut utiliser un subterfuge :

Sub Test()

    Dim Th As Date
    Dim H20 As Date

    Th = CDate("17:00")
    H20 = CDate("22:00")

    If H20 > Th Then
        MsgBox "-" & Application.Text(H20 - Th, "[h]:mm")
    Else
        MsgBox Application.Text(Th - H20, "[h]:mm")
    End If

End Sub
Le 01/09/2016 à 13:40

Merci pour votre contribution mais ça beug encore et j'avoue que j'ai passé une grosse partie de la journée sans comprendre ce qui se passe. Pourriez-vous m'aidez à trouver l'erreur ?

63essai-heure-sup-24-v-2.xlsm (34.17 Ko)
Le 01/09/2016 à 19:54

Bonsoir,

Quand tu convertis en date un texte, il ne peut excéder 23:59:59 donc, ta valeur de 99:00 génère une erreur avec CDate() :

H20 = CDate(TB20.Value)

Pour que ça fonctionne comme tu le désires, il te faut une fonction perso, si j'ai 5 mn, je me penche dessus pour te pondre quelque chose !

Le 02/09/2016 à 07:13

Bonjour,

Je viens de pondre une fonction pour le calcul des heures (addition et soustraction) teste si ça convient :

Function TotalHeure(Temps1 As String, Temps2 As String) As String

    Dim Jour1 As Single
    Dim Jour2 As Single
    Dim Mn1 As Single
    Dim Mn2 As Single

    'extrait les heures (partie gauche)
    Jour1 = CSng(Left(Temps1, 2))
    Jour2 = CSng(Left(Temps2, 2))

    'calcule en heure
    Jour1 = Jour1 / 24
    Jour2 = Jour2 / 24

    'calcule les minutes
    If InStr(Jour1, ",") <> 0 Then Mn1 = CSng("0," & Split(Jour1, ",")(1))
    Mn1 = Mn1 + 1 / 24 / 60 * CSng(Split(Temps1, ":")(1))

    If InStr(Jour2, ",") <> 0 Then Mn2 = CSng("0," & Split(Jour2, ",")(1))
    Mn2 = Mn2 + 1 / 24 / 60 * CSng(Split(Temps2, ":")(1))

    'transforme en Single
    Jour1 = CSng(Split(Jour1, ",")(0)) + Mn1
    Jour2 = CSng(Split(Jour2, ",")(0)) + Mn2

    'soustraction ou addition
    If Jour1 > Jour2 Then
        TotalHeure = Application.Text(Jour1 + Jour2, "[h]:mm")
    Else
        TotalHeure = "-" & Application.Text(Jour2 - Jour1, "[h]:mm")
    End If

End Function

une petite proc pour le test de la fonction :

Sub Test()

    MsgBox TotalHeure("24:45", "36:30")

End Sub
Le 02/09/2016 à 15:47

Je te remercie vivement pour ton aide. Avec la fonction personnalisée que tu as conçue, il n'y a plus de beug mais le calcul ne se fait pas en TB24 (TB20+TB21). On va y arriver ! Je t'envoie le fichier retravailler. Sans doute ai-je encore fait des erreurs ! Mais n'est-ce pas ainsi qu'on progresse ?

A te lire

Seb

103essai-heure-sup-24-v-3.xlsm (39.17 Ko)
Le 03/09/2016 à 08:49

Bonjour,

J'ai remanié ma fonction (séparateur décimal au cas ou, et valeur négative pour le second argument). Tu colle tout le code ci-dessous (fonction comprise puisqu'elle est appelée !) à la place de la procédure évènementielle "Private Sub CommandButton4_Click()" :

Private Sub CommandButton4_Click()

    Dim H4 As Date
    Dim H6 As Date
    Dim H8 As Date
    Dim H10 As Date
    Dim H15 As Date
    Dim Temps1 As String
    Dim Temps2 As String

    H4 = CDate(tb4.Value)
    H6 = CDate(TB6.Value)
    H8 = CDate(TB8.Value)
    H10 = CDate(TB10.Value)
    H15 = CDate(TB15.Value)

    Temps2 = TB21.Text

    'calcul des heures suplémentaires prises ou gagnées du jour
    Temps2 = H6 - (H8 + H10 + H4 + H15) 'total

    If Temps2 <= 0 Then
      TB21.Value = Format(Temps2, "hh:mm")
    Else
      TB21.Value = Format(Temps2, "-hh:mm")
    End If

    'calcul des congés payés pris du jour
    'On Error Resume Next
    TB19.Value = CDbl(TB16.Value) - CDbl(TB18.Value)

    'calcul du solde d'heure supplémentaires restantes
    'les valeurs passée doivent être sous le format "00:00" ou pour TB21.Text (si négatif) "-00:00"
    TB24.Text = TotalHeure(TB20.Text, TB21.Text)

End Sub

Function TotalHeure(Temps1 As String, Temps2 As String) As String

    Dim Jour1 As Single
    Dim Jour2 As Single
    Dim Mn1 As Single
    Dim Mn2 As Single
    Dim Sep As String

    'séparateur décimal
    Sep = Format(0, ".")

    'extrait les heures (partie gauche)
    Jour1 = CSng(Split(Temps1, ":")(0))
    Jour2 = CSng(Split(Temps2, ":")(0))

    'calcule en heure
    Jour1 = Jour1 / 24
    Jour2 = Jour2 / 24

    'calcule les minutes
    If InStr(Jour1, Sep) <> 0 Then Mn1 = CSng("0" & Sep & Split(Jour1, Sep)(1))
    Mn1 = Mn1 + 1 / 24 / 60 * CSng(Split(Temps1, ":")(1))

    If InStr(Jour2, Sep) <> 0 Then Mn2 = CSng("0" & Sep & Split(Jour2, Sep)(1))
    Mn2 = Mn2 + 1 / 24 / 60 * CSng(Split(Temps2, ":")(1))

    'transforme en Single
    Jour1 = CSng(Split(Jour1, Sep)(0)) + Mn1
    Jour2 = CSng(Split(Jour2, Sep)(0)) + Mn2

    'si le temps est négatif, tranforme en négatif
    If InStr(Temps2, "-") <> 0 Then Jour2 = -Jour2

    'soustraction ou addition
    If Jour1 > Jour2 Then
        TotalHeure = Application.Text(Jour1 + Jour2, "[h]:mm")
    Else
        TotalHeure = "-" & Application.Text(Jour2 - Jour1, "[h]:mm")
    End If

End Function
Le 03/09/2016 à 09:10

Re,

Nouvelle correction de ma fonction

Je n'avais pas pris en compte une valeur de temps négative pour le second argument qui en absolue pouvait être supérieure à celle du premier argument donc, fonction à remplacer par cette dernière mouture :

Function TotalHeure(Temps1 As String, Temps2 As String) As String

    Dim Retour As String
    Dim Jour1 As Single
    Dim Jour2 As Single
    Dim Mn1 As Single
    Dim Mn2 As Single
    Dim Sep As String

    'séparateur décimal
    Sep = Format(0, ".")

    'extrait les heures (partie gauche)
    Jour1 = CSng(Split(Temps1, ":")(0)) 'CSng(Left(Temps1, 2))
    Jour2 = CSng(Split(Temps2, ":")(0)) 'CSng(Left(Temps2, 2))

    'calcule en heure
    Jour1 = Jour1 / 24
    Jour2 = Jour2 / 24

    'calcule les minutes
    If InStr(Jour1, Sep) <> 0 Then Mn1 = CSng("0" & Sep & Split(Jour1, Sep)(1))
    Mn1 = Mn1 + 1 / 24 / 60 * CSng(Split(Temps1, ":")(1))

    If InStr(Jour2, Sep) <> 0 Then Mn2 = CSng("0" & Sep & Split(Jour2, Sep)(1))
    Mn2 = Mn2 + 1 / 24 / 60 * CSng(Split(Temps2, ":")(1))

    'transforme en Single
    Jour1 = CSng(Split(Jour1, Sep)(0)) + Mn1
    Jour2 = CSng(Split(Jour2, Sep)(0)) + Mn2

    'si le temps est négatif, tranforme en négatif
    If InStr(Temps2, "-") <> 0 Then Jour2 = -Jour2

    'soustraction ou addition
    If Jour1 > Jour2 Then

        'si en absolu la valeur de Jour2 est suppérieure à celle de Jour1 transforme en absolu
        'ces valeurs afin de ne pas avoi d'erreur avec la fonction Text mais ajoute le signe moins
        If Jour2 < 0 Then
            Retour = "-" & Application.Text(Abs(Jour1 - Abs(Jour2)), "[h]:mm")
        Else
            Retour = Application.Text(Jour1 + Jour2, "[h]:mm")
        End If

    Else
        Retour = "-" & Application.Text(Jour2 - Jour1, "[h]:mm")
    End If

    'si le signe moins devant une valeur égale à 0, supprime le signe
    If Retour = "-0:00" Then Retour = "00:00"

    TotalHeure = Retour

End Function
Le 03/09/2016 à 18:14

Merci infiniment. Je croyais qu'une fonction s'intégrait dans un module. Tout marche à merveille. Bravo à toi, à l'existence de ce forum et à ceux qui le font vivre.

Seb

Rechercher des sujets similaires à "code vba additionner heures superieures"