Perte de l'heure dans une date

jot

XLDnaute Nouveau
Bonjour,

description du besoin :
à partir d'une date et heure donnée je souhaite ajouter un nbre de jours ouvrés afin d'obtenir une nouvelle date et heure. Pour cela j'utilise du code VB, le pb est que dans le résultat je n'ai plus l'heure.

ci-dessous le code utilisé.

merci d'avance de votre aide

cels(k,19) : cellule de départ
cells(k,47) : cellule d'arrivée

Cells(k, 47) = PlusJOuvres(Cells(k, 19), Cells(k, 21))

Function PlusJOuvres(D, NbJours)
Dim Dt, i
Dim NbOr, Epacte As Integer
Dim PLune, LPaques, Arr(10) As Long

Dt = CLng(D)
Do
Dt = Dt + 1
'calcul du Lundi de Pâques
NbOr = (An Mod 19) + 1
Epacte = (11 * NbOr - (3 + Int(2 + Int(An / 100)) * 3 / 7)) Mod 30
PLune = DateSerial(An, 4, 19) - ((Epacte + 6) Mod 30)
If Epacte = 24 Then PLune = PLune - 1
If Epacte = 25 And (An >= 1900 And An < 2200) Then PLune = PLune - 1
LPaques = PLune - Weekday(PLune) + vbMonday + 7 'Lundi Paques

'tableau des fériés
Arr(0) = DateSerial(An, 1, 1)
Arr(1) = LPaques
Arr(2) = LPaques + 38 'Ascencion
Arr(3) = LPaques + 49 'Pentecôte
Arr(4) = DateSerial(An, 5, 1)
Arr(5) = DateSerial(An, 5, 8)
Arr(6) = DateSerial(An, 7, 14)
Arr(7) = DateSerial(An, 8, 15)
Arr(8) = DateSerial(An, 11, 1)
Arr(9) = DateSerial(An, 11, 11)
Arr(10) = DateSerial(An, 12, 25)

'ajoute si ouvré
If (IsError(Application.Match(Dt, Arr, 0))) = True And _
(Weekday(Dt, vbMonday) < 6) = True Then
i = i + 1
End If
Loop Until i = NbJours

PlusJOuvres = Dt

End Function
 

Gael

XLDnaute Barbatruc
Re : Perte de l'heure dans une date

Bonjour Jot,

Ci-dessous ta procédure modifiée.

Le tableau des jours fériés n'éest à réaliser qu'une fois, il vaut mieux le placer en dehors de la boucle sinon il se recalcule à chaque passage.

L'instruction Dt=Clng(D) est nécessaire pour avoir un nombre entier à comparer avec la table de jours fériés, mais ce faisant, tu perds les décimales associées à D qui représentent le nombre d'heures.

J'ai donc ajouté une variable n qui compte les passages dans la boucle et à la fin on met: "PlusJOuvres = D + n" ce qui permet de récupérer les décimales de D.

L'instruction "Application.Match(Dt, Arr, 0)" ne fonctionne pas chez moi, le résultat est toujours en erreur donc ISerror est toujours vrai même si la date fait partie du tableau. A vérifier si cela marche chez toi.

Le code modifié:

Code:
Function PlusJOuvres(D, NbJours)
Dim Dt As Date, i, An, n As Integer
Dim NbOr, Epacte As Integer
Dim PLune, LPaques, Arr(10) As Long
An = Year(D)
'calcul du Lundi de Pâques
NbOr = (An Mod 19) + 1
Epacte = (11 * NbOr - (3 + Int(2 + Int(An / 100)) * 3 / 7)) Mod 30
PLune = DateSerial(An, 4, 19) - ((Epacte + 6) Mod 30)
If Epacte = 24 Then PLune = PLune - 1
If Epacte = 25 And (An >= 1900 And An < 2200) Then PLune = PLune - 1
LPaques = PLune - Weekday(PLune) + vbMonday + 7 'Lundi Paques
'tableau des fériés
Arr(0) = DateSerial(An, 1, 1)
Arr(1) = LPaques
Arr(2) = LPaques + 38 'Ascencion
Arr(3) = LPaques + 49 'Pentecôte
Arr(4) = DateSerial(An, 5, 1)
Arr(5) = DateSerial(An, 5, 8)
Arr(6) = DateSerial(An, 7, 14)
Arr(7) = DateSerial(An, 8, 15)
Arr(8) = DateSerial(An, 11, 1)
Arr(9) = DateSerial(An, 11, 11)
Arr(10) = DateSerial(An, 12, 25)
Dt = CLng(D)
Do
Dt = Dt + 1
'ajoute si ouvré
If (IsError(Application.Match(Dt, Arr, 0))) = True And _
(Weekday(Dt, vbMonday) < 6) = True Then
i = i + 1
End If
n = n + 1
Loop Until i = NbJours
PlusJOuvres = D + n
End Function

@+

Gael
 

Gael

XLDnaute Barbatruc
Re : Perte de l'heure dans une date

Bonsoir Jot,

Exact, j'ai fait 2 erreurs:

1 - il vaut mieux définir DT comme entier long et non pas comme date. Dans ce cas, la comparaison avec la table des fériés marche correctement. Donc: "Dim Dt as Long".

2 - Les fonctions de conversion comme Clng vont arrondir le nombre au chiffre supérieur lorsque les décimales sont supérieures à 0,5. Si l'heure est supérieure à 12:00, le nombre sera augmenté de 1.
Dans ce cas, il faut utiliser "Int(D)" qui tronque la partie décimale sans arrondi au lieu de CLng. Donc: "Dt=Int(D)"

@+

Gael
 

Gael

XLDnaute Barbatruc
Re : Perte de l'heure dans une date

Bonjour Jot,

Une autre erreur est d'avoir répondu à ta question sans trop réfléchir car à moins de vouloir absolument faire une macro, il y a une fonction Excel qui fait ça directement:

Code:
SERIE.JOUR.OUVRE(date_départ;nb_jours;jours_fériés)

Cette fonction ne récupère pas les heures que l'on peut ajouter au résultat.

Par ailleurs, il reste un problème dans ton code si la date de départ et la date résultat se trouvent sur 2 années différentes puisque les fériés ne sont calculés que sur une année.

Ex: 26/12/08 + 10 jours

Pour régler ce problème, il faudrait calculer les fériés sur 2 ans, l'année de la date de départ et la suivante.

@+

Gael
 
Dernière édition:

jot

XLDnaute Nouveau
Re : Perte de l'heure dans une date

merci bcp pour l'aide, ca fonctionne maintenant

pour la suggestion , en effet j'ai déjà actuellement dans mon excel cette fonction serie.jour.ouvres .

mais comme je devais passer en macro pour autre chose j'en profite pour coder le reste
 

Gael

XLDnaute Barbatruc
Re : Perte de l'heure dans une date

Bonjour Jot,

A toutes fins utiles, un exemple en formules avec les jours fériés calculés automatiquement sur 2 ans à partir de la date saisie (avec récupération de l'heure).

@+

Gael
 

Pièces jointes

  • Calcul_feries_Jot.xls
    17 KB · Affichages: 55

Discussions similaires

Réponses
17
Affichages
760

Statistiques des forums

Discussions
311 710
Messages
2 081 781
Membres
101 817
dernier inscrit
carvajal