determiner une serie de jours ouvrés avant et après un weekend ou un jour ferié à partir d'une date

[Monhtc]

Bonjour chers tous
j'ai besoin d'une aide pour automatiser determiner une serie de jours ouvrés avant et après un weekend ou un jour ferié à partir d'une date début.
EXEMPLE: POUR UNE PERIODE DU 14 FEVRIER AU 01 MARS; COMMENT OBTENIR
PERIODE 1: Date de début: jeudi 14 février - Date de fin: vendredi 15 février
PERIODE 2: Date de début: Lundi 18 février - Date de fin: vendredi 22 février
PERIODE 3: Date de début: lundi 25 février - Date de fin: vendredi 01 mars

 

[pierrejean]

Bonjour Monhtc

Un essai

 

[job75]

Bonjour Monhtc, Pierre,

S'il s'agit de déterminer les lundis et vendredis voyez le fichier joint et les formules en B4 C4 D4.

A+

 

[job75]

Bonjour Monhtc, Pierre,

Je n'avais pas bien compris ni vu qu'il y avait déjà cette discussion :

https://www.excel-downloads.com/threads/determiner-serie-de-periode-de-jours-ouvres.20029038/

Si l'on veut traiter aussi les jours fériés il faut en effet utiliser la fonction SERIE.JOUR.OUVRE, voyez ce fichier (2).

Formule en C4 :

=SIERREUR(SI(LIGNES(C$4:C4)=1;SERIE.JOUR.OUVRE(C3-1;1;Feries);SERIE.JOUR.OUVRE(C3+6-JOURSEM(C3;2);1;Feries))/(SI(LIGNES(C$4:C4)=1;SERIE.JOUR.OUVRE(C3-1;1;Feries);SERIE.JOUR.OUVRE(C3+6-JOURSEM(C3;2);1;Feries))<=D$3);"")

Formule en D4 :

=SIERREUR(SI(SERIE.JOUR.OUVRE(C4+6-JOURSEM(C4;2);-1;Feries)>D$3;SERIE.JOUR.OUVRE(D$3+1;-1;Feries);SERIE.JOUR.OUVRE(C4+6-JOURSEM(C4;2);-1;Feries));"")

A+

 

[Monhtc]

superbe boulot merci Job75 vous êtes un génie. Je viens vous répondre avec ci joint le fichier définitif et le boulot tel que je voudrais le présenter avec la mise en forme

 

[job75]

Re,

Avant de traiter votre post #5 voici une solution VBA avec cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim deb As Date, fin As Date, dest As Range, d As Object, dat As Variant, resu(), flag As Boolean, n&
deb = [C3] 'à adapter
fin = [D3] 'à adapter
Set dest = [B3] 'à adapter
'---mémorisation des jours fériés pour accélérer---
Set d = CreateObject("Scripting.Dictionary")
For Each dat In [Feries].Value: d(dat) = "": Next
'---tableau des résultats---
ReDim resu(1 To fin - deb + 1, 1 To 3)
For dat = deb To fin
    If Not flag And Weekday(dat, 2) < 6 And Not d.exists(dat) Then
        flag = True
        n = n + 1
        resu(n, 1) = n
        resu(n, 2) = dat
    End If
    If flag And (Weekday(dat, 2) > 5 Or d.exists(dat)) Then flag = False: resu(n, 3) = dat - 1
Next
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
dest(2).Resize(Rows.Count - dest.Row, 3).Delete xlUp 'RAZ
If n Then
    If resu(n, 3) = "" Then resu(n, 3) = fin
    dest(2).Resize(n, 3) = resu
    dest(2, 2).Resize(n, 2).Interior.ColorIndex = 6 'jaune
    dest(2, 2).Resize(n, 2).Borders.Weight = xlHairline 'bordures
End If
Application.EnableEvents = True 'réactive les évènements
End Sub

Elle est mieux que celle de mon post #4 car le 01/05/2019 est exclu des périodes listées.

A+

 

[job75]

Re,

Voici la macro pour le fichier du post #5 :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim deb As Date, fin As Date, dest As Range, d As Object, dat As Variant, resu(), n&, flag As Boolean, i&
deb = [A3] 'à adapter
fin = [A5] 'à adapter
Set dest = [C7] 'à adapter
'---mémorisation des jours fériés pour accélérer---
Set d = CreateObject("Scripting.Dictionary")
For Each dat In [Feries].Value: d(dat) = "": Next
'---tableau des résultats---
ReDim resu(1 To 2 * IIf(fin < deb, 0, fin - deb) + 3, 1 To 3)
n = -1
For dat = deb To fin
    If Not flag And Weekday(dat, 2) < 6 And Not d.exists(dat) Then
        flag = True
        n = n + 2
        resu(n, 1) = "PERIODE " & 1 + (n - 1) / 2
        resu(n, 2) = "DATE DE DEPART"
        resu(n, 3) = dat
        resu(n + 1, 2) = "DATE DE RETOUR"
    End If
    If flag And (Weekday(dat, 2) > 5 Or d.exists(dat)) Then flag = False: resu(n + 1, 3) = dat - 1
Next
If n > -1 Then If resu(n + 1, 3) = "" Then resu(n + 1, 3) = fin
resu(n + 2, 1) = "IMPUTATION BUDGETAIRE"
resu(n + 2, 3) = Application.VLookup("IMPUTATION BUDGETAIRE", dest.EntireColumn.Resize(, 3), 3, 0)
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
dest(2).Resize(Rows.Count - dest.Row, 3).Delete xlUp 'RAZ
dest(2).Resize(n + 2, 3) = resu
'---fusion des cellules---
If n > 1 Then
    For i = 1 To n Step 2
        dest(i + 1).Resize(2).Merge
        dest(i + 1).VerticalAlignment = xlCenter
    Next
ElseIf n = 1 Then
    dest(2, 2).Resize(2).Cut dest(2)
    dest(2).Resize(, 2).Merge
    dest(3).Resize(, 2).Merge
End If
dest(n + 3).Resize(, 2).Merge 'IMPUTATION BUDGETAIRE
'---bordures---
dest(2).Resize(n + 2, 3).Borders.Weight = xlThin 'bordures
Application.EnableEvents = True 'réactive les évènements
End Sub

Edit 1 : j'ai corrigé le test If n > -1 Then

Edit 2 : dimensionné resu pour le cas où fin < deb.

A+

 

[job75]

Pour ce qui est du transfert dans Word il y a de nombreux exemples sur ce forum.

 

[Monhtc]

Bonjour Job75. Merci (x1000) vraiment pour tout à vous Job75😉😉😉. Ça marche nickel 😉tout fonctionne à merveille. Merci pour votre ingéniosité.
J'ai aussi un collègue qui de son coté à monter un formulaire de saisie mais n'a pas réussi à monter les périodes comme vous l'avez fait avec brio.
J'aimerais savoir si c'est aussi possible de faire pareil avec les différents champs:
-DONNE L’ORDRE A (liste déroulante)
-FONCTION (liste déroulante)
-CONTACTS
-D'EFFECTUER UNE MISSION A
-OBJET DE LA MISSION
-MOYEN DE TRANSPORT
-IMPUTATION BUDGÉTAIRE

NB: la fonction donne l'ordre à et contact marchent comme une recherche, Il suffit de taper l'une de ses informations et les autres infos relatives apparaissent. C'est à dire le nom de l'employé si son contact est tapé ou le numéro (contact) si son nom est tapé.
Je vous remercie de votre attention et votre assistance depuis le début

 

[job75]

Bonjour Monhtc, le forum,

Pas compris votre nouvelle demande.

J'en ai profité pour corriger une petite erreur au post #7.

Bonne journée.

 

[Monhtc]

Encore merci, je ne cesserai de vous dire merci pour votre assistance. En effet j'aimerais crée un formulaire de validation avec les differents champs
UN NUMERO D ORDRE DE MISSION
-DONNE L’ORDRE A (liste déroulante)
-FONCTION (liste déroulante)
-CONTACTS
-D'EFFECTUER UNE MISSION A
-OBJET DE LA MISSION
-MOYEN DE TRANSPORT
-DATE DE DÉPART (Avec les memes calculs de periodes se remplissants automatiquement AVEC LES MISE EN FORME DATE LONGUE)
-DATE DE RETOUR (Avec les memes calculs de periodes se remplissants automatiquement AVEC LES MISE EN FORME DATE LONGUE)
-IMPUTATION BUDGÉTAIRE
Mais aussi avec une base de données sur une autre feuille pour retracer tous les ODM
NB: Une personne peut occuper deux fonctions ou non

 

[job75]

Bonjour Monhtc, le forum,

Dans ce fichier (2) je me suis occupé uniquement du transfert de l'ODM dans la feuille BASE DE DONNEES :

Sub Transfert(dest As Range)
Dim F As Worksheet, lig&, n&, p&
Set dest = dest.Offset(-5) '1ère cellule du tableau
Set F = Feuil3 'CodeName de la feuille BASE DE DONNEES
If F.[G2] = "" Then lig = 2 Else lig = Application.Match(9 ^ 9, F.[G:G]) + 1
For n = 7 To dest.Row + dest.CurrentRegion.Rows.Count - 3 Step 2
    F.Cells(lig + p, 7) = dest(n, 3)
    F.Cells(lig + p, 8) = dest(n + 1, 3)
    p = p + 1
Next
F.Cells(lig, 9).Resize(p) = dest(n, 3)
For n = 1 To 6
    F.Cells(lig, n).Resize(p) = dest(n, 3)
Next
F.[A1].CurrentRegion.RemoveDuplicates _
    Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes 'supprime les doublons
End Sub

L'utilisation de l'UserForm n'est plus le sujet de ce fil et il y a de nombreux exemples sur ce forum, je n'irai donc pas plus loin.

A+

 

[Monhtc]

Bonsoir Job. Je n'arrive pas à rajouter des lignes encore moins des colonnes à mon classeur. Alors que j'aimerais pouvoir rajouter des logos en haut de part et d'autres afin de personnaliser la mise en forme pour impression.
Merci

 

[job75]

Bonjour Monhtc,

Je n'arrive pas à rajouter des lignes encore moins des colonnes à mon classeur.

Bah vous devez savoir ce qu'il faut faire pour que je puisse vous aider...

J'en ai profité pour compléter la macro du post #7 avec le cas où fin < deb.

A+

 

[Monhtc]

Merci pour votre disponibilité. J'ai joint cette fois à mon post les indications poussées