Calcul du nombre max de jour consécutifs

Bonjour à tous,

afin d'aider un membre je bûche sur un problème, je viens donc à l'aide....

dans le principe, la base initiale est une liste des absences-arrêts maladie ..... pour les employés.

dans la demande on demande de déterminer le nombre de jours max consécutifs non travaillé pour chaque employé... et cela en excluant les jours ou l'entreprise est fermée => les samedi et dimanche...

j'ai essayé de faire un code en utilisant les filtres élaborés, puis boucle de comptage mais je ne m'en sort pas.....

si quelqu'un a une idée

dans le fichier exemple ci joint j'ai fait fait un exemple manuellement pour vous puissiez comprendre....

Merci

Fred

23exemple.xlsx (12.35 Ko)

Bonjour,

par formules ? Ca risque d'etre chaud...

Si l'arret démarre un AM ou fini un matin, tu comptes 0.5 en plus ?

Peut-on trier comme on veut ?

En fait c'est facile. Comme ils sont absents alternativement soir et matin 1 jour sur 2, ça fait max 1/2 journée pour tout le monde. Et sans calculette stp !

eric

SAlut Eriic

non par formule je sais que c'est chaud... donc non plus facilement par VBA je penses, ce que j'ai commencé a faire... mais sans succès

a priori non on compte une journée par date inscrite dans la colonne D on ne compte pas de demi journées (je ne sais pas pourquoi... je vais voir si je peux obtenir plus d'infos la dessus...)

A priori tu peux faire ce que tu veux comme tri

merci

Fred

edit : c'est peut-être toi qui a raison, et qu'il faut compter comme cela.... mais ca veux dire que la demande initiale est mal formulée alors

ok, mais il faudrait savoir si chaque date apparait systématiquement 2 fois, ce qui n'est pas le cas dans l'exemple fourni.

Voici la phrase de la demande initiale :

afficher le nombre de jours maximum d'absence continu (sans tenir compte des week-end et jours fériés).

je vais à la pêche aux infos et dès que j'ai une réponse je reviens.... (certainement demain)...

Merci

Fred

bonjour

une pre etude ;mais ,y a un mais ......

16pre-etude.xlsx (324.72 Ko)

cordialement

Bonsoir à tous,

Une première approche :

Restitution en Feuil2

Option Explicit
Sub test()
Dim a, w(), i As Long, n As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Feuil1").Range("b1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            ReDim w(1 To 5, 1 To 1)
        Else
            w = dico.Item(a(i, 1))
            If a(i, 3) > w(5, UBound(w, 2)) Then
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
        End If
        If IsEmpty(w(1, UBound(w, 2))) Then
            w(1, UBound(w, 2)) = a(i, 1)
            w(2, UBound(w, 2)) = a(i, 3)
        End If
        If w(3, UBound(w, 2)) <> a(i, 3) Then
            w(4, UBound(w, 2)) = w(4, UBound(w, 2)) + 1
        End If
        w(3, UBound(w, 2)) = a(i, 3)
        w(5, UBound(w, 2)) = a(i, 3) + 1
        dico.Item(a(i, 1)) = w
    Next
    With Sheets("feuil2").Range("a1")
        .Parent.Cells.Clear
        For i = 0 To dico.Count - 1
            With .Offset(n).Resize(UBound(dico.items()(i), 2), UBound(dico.items()(i), 1) - 1)
                .FormulaLocal = Application.Transpose(dico.items()(i))
                .BorderAround Weight:=xlThin
            End With
            n = n + UBound(dico.items()(i), 2) + 1
        Next
    End With
    Set dico = Nothing
End Sub

Ceci est à revoir :

If w(3, UBound(w, 2)) <> a(i, 3) Then
    w(4, UBound(w, 2)) = w(4, UBound(w, 2)) + 1
End If

il faut boucler sur chaque clé et décompter les jours autrement

klin89

Re fred2406,

Les dates figurant en feuille source doivent être triées par ordre chronologique

Vois ceci :

Option Explicit
Sub test()
Dim a, w(), e, txt As String, dico As Object
Dim i As Long, j As Long, n As Long
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Feuil1").Range("b1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
        If Not dico.exists(txt) Then
            ReDim w(1 To 6, 1 To 1)
        Else
            w = dico.Item(txt)
            If a(i, 3) > w(6, UBound(w, 2)) Then
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
        End If
        If IsEmpty(w(1, UBound(w, 2))) Then
            w(1, UBound(w, 2)) = a(i, 1)
            w(2, UBound(w, 2)) = a(i, 2)
            w(3, UBound(w, 2)) = a(i, 3)
        End If
        w(4, UBound(w, 2)) = a(i, 3)
        w(6, UBound(w, 2)) = a(i, 3) + 1
        dico.Item(txt) = w
    Next
    For Each e In dico.keys
        w = dico.Item(e)
        For j = 1 To UBound(w, 2)
            w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """)")
        Next
        dico.Item(e) = w
    Next
    With Sheets("feuil2").Range("a1")
        .Parent.Cells.Clear
        For i = 0 To dico.Count - 1
            With .Offset(n).Resize(UBound(dico.items()(i), 2), UBound(dico.items()(i), 1) - 1)
                .FormulaLocal = Application.Transpose(dico.items()(i))
                .BorderAround Weight:=xlThin
            End With
            n = n + UBound(dico.items()(i), 2) + 1
        Next
    End With
    Set dico = Nothing
End Sub

klin89

Bonsoir tout le monde

merci pour vos réponses je vais étudier cela demain

Bonne nuit

Fred

Re fred2406,

Résultat dans la variable b

Option Explicit
Sub test()
Dim a, b(), w(), e, txt As String, dico As Object
Dim i As Long, j As Long, n As Long, maxi As Long, pos
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Feuil1").Range("b1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
        If Not dico.exists(txt) Then
            ReDim w(1 To 6, 1 To 1)
        Else
            w = dico.Item(txt)
            If a(i, 3) > w(6, UBound(w, 2)) Then
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
        End If
        If IsEmpty(w(1, UBound(w, 2))) Then
            w(1, UBound(w, 2)) = a(i, 1)
            w(2, UBound(w, 2)) = a(i, 2)
            w(3, UBound(w, 2)) = a(i, 3)
        End If
        w(4, UBound(w, 2)) = a(i, 3)
        w(6, UBound(w, 2)) = a(i, 3) + 1
        dico.Item(txt) = w
    Next
    ReDim b(1 To dico.Count, 1 To 5)
    For Each e In dico.keys
        w = dico.Item(e)
        For j = 1 To UBound(w, 2)
            w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """)")
        Next
        dico.Item(e) = w
        maxi = Application.Max(Application.Index(w, 5, 0))
        pos = Application.Match(maxi, Application.Index(w, 5, 0), 0)
        n = n + 1
        For j = 1 To UBound(w, 1) - 1
            b(n, j) = w(j, pos)
        Next
    Next
    'Restitution en Feuil2
    Application.ScreenUpdating = False
    With Sheets("feuil2")
        .Cells.Clear
        With .Range("a1").Resize(UBound(b, 1), UBound(b, 2))
            .FormulaLocal = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .VerticalAlignment = xlCenter
            .Columns.ColumnWidth = 12
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour Klin89, bonjour le forum

merci pour ton code qui a priori repond a la demande... j'attends toujours confirmation de la personne qui pose cette question....

chez moi ton code fonctionne (avant dernier... celui que tu as mis il y a 1/2 heure pas regardé encore...) et j'ai réussi a mon imprégner à une exception près.... je cherche encore un peu... mais si je n'y arrive pas je viendrais te poser une question

mais il y a une chose qui ne fonctionne pas .... c'est cette ligne

w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """)")

qui me renvoi une erreur

je l'ai remplacé par

w(4, j) = WorksheetFunction.NetworkDays(w(2, j), w(3, j))

et c'est OK

la chose que je ne m'explique pas encore c'est que cette fonction nbjourouvré, attend un 3e paramètre en option correspondant aux jours fériés.. du pays dans lequel on est et j'avais commencé a mettre en mémoire les jours fériés, et je me suis aperçu que cette fonction, même sans ce paramètre en option, me comptait le 14 juillet comme jour non travaillé, et autres jours que j'ai pu tester...

merci et bon dimanche

fred

re

je viens de regarder ton dernier code, c'est bien... tu m'a fait quelque chose que j'étais entrain de faire ajouter le prénom dans le dico pour éviter les homonymes.... j'avais penser a quelque chose de similaire ça tombe bien...

fred

Re,

Tu listes les jours fériés dans une plage que tu nommes "feries"

et tu modifies comme ceci, cela fonctionne non !

For j = 1 To UBound(w, 2)
    'w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """)")
    w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """,feries)")
Next

Chez moi sous Excel 2003, ça fonctionne

ou ceci :

For j = 1 To UBound(w, 2)
    w(5, j) = Evaluate("Networkdays(""" & w(3, j) & """,""" & w(4, j) & """,feries)")
    'w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """,feries)")
    'w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """)")
Next

klin89

Re

si j'utilise ta ligne de code :

w(5, j) = Evaluate("NB.JOURS.OUVRES(""" & w(3, j) & """,""" & w(4, j) & """,feries)")

j'ai w(5,i) qui est egal à Erreur 2029

cela marche avec la ligne suivante

     w(5, j) = WorksheetFunction.NetworkDays(w(3, j), w(4, j), Range("feries"))

mais pas la tienne, mais je me demande si on est obligé de mettre ce tableau de dates....

autre question, est-il possible de mettre les jours feriés dans une varaible de type tableau au lieu de passer par une plage de cellule dans une feuille ?? car j'ai essayé de 3 façons possible je n'y arrive pas, la question est est ce que cela est même possible....

Fred

red2406 a dit :

autre question, est-il possible de mettre les jours feriés dans une varaible de type tableau au lieu de passer par une plage de cellule dans une feuille ?? car j'ai essayé de 3 façons possible je n'y arrive pas, la question est est ce que cela est même possible....

Oui, c'est possible, vois la manip dans le lien ci-dessous

https://excel2007manual.blogspot.com/2013/06/store-holidays-in-named-range.html

klin89

bonsoir

c'est pas tout a fait ce que je demandais... si j'ai bien compris c'est pour mettre dans une variable du gestionnaire de noms en dur comme ca si la plage est supprimée cela ne pose pas de problème ..... , l e problème c'est que chaque année faudrait faire une modif à la main ... je vais resté avec une feuille masquée cela fera l'affaire...

j'ai fais des recherches et a priori le 3e argument de cette fonction doit être un range... donc moi je sais pas convertir un tb() en range...

je problème viens de la

mais bon une autre solution est opérationnelle donc pas grave....

merci

fred

Bonsoir

je viens d'avoir les informations nécessaire... et Eriic avait raison..... quand un personne est absent une demi journée, elle n'est pas comptabilisée absente....

voici enfin le retour que j'ai eut ce soir ...

- 1 agent absent 1/2 journée sera compté comme présent, il faut être absent 1 journée complète pour que le décompte commence (dans l'idéal les jours fériés serait de neutraliser les jours fériés comme le sont les samedis et les dimanches)

  • le comptage du nombre maximum d'absences est égal au nombre d'absences journalières complètes consécutives hors jours fériés, et week-end

Je vais donc essayé d'adapter le code Klin pour que cela fonctionne comme avec ce nouveau fonctionnement

Bonne soirée

Fred

bonjour faute de temps je clôture le sujet, une autre personne pourra aider la personne en question..

merci à tous

fred

Rechercher des sujets similaires à "calcul nombre max jour consecutifs"