Calculateur d'absence selon plusieurs fichiers

Le 27/10/2020 à 17:06

En effet je vais faire comme ça ! Merci !

Pour les dates de vacances scolaires tu me conseil quoi ?

Le 27/10/2020 à 17:14

Demain, je te ferai :

  1. la visualisation des vacances scolaires dans les 3 zones ou une seule et laquelle ?
  2. un module de compilation des 4 plannings
Le 27/10/2020 à 17:19

Les 3 zones serait parfait ! (Plusieurs collaborateurs sur toute la France)

Merci beaucoup encore une fois !

Le 28/10/2020 à 05:59
Steelson a écrit :

Demain, je te ferai :

  1. la visualisation des vacances scolaires dans les 3 zones ou une seule et laquelle ?
  2. un module de compilation des 4 plannings

Pour le point 2 :

Option Explicit
Sub compiler()
Dim c As Workbook  ' compil
Dim s As Workbook  ' source
Dim f As String    ' nom du fichier
Dim r As String    ' répertoire
Dim o As String    ' onglet
Dim t As String    ' onglet contenant le TCD et réactivant la récap dans la source si nécssaire
Dim x As Long      ' ligne

    Set c = ThisWorkbook
    r = c.Path & "\SERVICES\" ' à modifier si nécessaire
    o = "Recap"
    t = "Synthese"
    f = Dir(r & "*.xlsm")

    If Not c.Sheets(o).ListObjects(1).DataBodyRange Is Nothing Then c.Sheets(o).ListObjects(1).DataBodyRange.Delete
    Do While f <> ""

        c.Sheets(o).ListObjects(1).ListRows.Add
        x = c.Sheets(o).ListObjects(1).ListRows.Count

        Set s = Workbooks.Open(r & f)
        s.Sheets(t).Select ' pou réactiver la compilation des mois dans le fichier source
        s.Sheets(o).ListObjects(1).DataBodyRange.Copy Destination:=c.Sheets(o).ListObjects(1).DataBodyRange.Cells(x, 1)

        Application.DisplayAlerts = False
            s.Close False
        Application.DisplayAlerts = True
        f = Dir

    Loop

End Sub
11services.zip (832.91 Ko)
Le 28/10/2020 à 15:57

Ca me vas bien, j'ai modifié un peu la macro pour l'adapter à mes fichiers,

Merci !

Le 28/10/2020 à 16:10
Anthony.w a écrit :

Ca me vas bien, j'ai modifié un peu la macro pour l'adapter à mes fichiers,

Merci !

Modifie r =  mais le reste laisse le en l'état !

pour le point 1, avec les vacances scolaires (2019/2020 et 2020/2021)

17planning-v3.xlsm (214.61 Ko)
Le 28/10/2020 à 16:27

Un retour sur le code pour la communauté

A l'activation de l'onglet Synthèse, on compile l'ensemble des onglets mensuels (une entorse à ma conception des choses) et on actualise le TCD

Private Sub Worksheet_Activate()
    COMPILER True
    ActiveSheet.PivotTables(1).PivotCache.Refresh
End Sub

Lorsqu'on change de feuille, ce code n'a aucune fonction si ce n'est d'empêcher les modifications incontrôlées de calendrier.

  1. s'il s'agit d'une feuille mensuelle on interdit de changer l'année et le mois en A4 et B4
  2. s'il s'agit de l'onglet calendrier, alors après confirmation on remettra aussi à zéro les feuilles mensuelles
Private Sub Workbook_SheetChange(ByVal f As Object, ByVal Target As Range)
If IsNumeric(Left(f.Name, 1)) Then
    If Not Intersect(Target, Range("A4:B4")) Is Nothing Then
        Application.EnableEvents = False
            Application.Undo
        Application.EnableEvents = True
        MsgBox "Pour modifier l'année, rendez-vous dans ''Calendrier'' !"
    End If
ElseIf f.Name = "Calendrier" Then
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        Application.EnableEvents = False
            rep = MsgBox("Etes vous sûr(e) de vouloir changer l'année ?" & vbCrLf & "Si OUI : ceci effacera toutes les données ... (faites alors auparavant une sauvegarde)", vbYesNo, "Sondage")
            If rep = vbYes Then
                raz True
            ElseIf rep = vbNo Then
                Application.Undo
            Else
            End If
        Application.EnableEvents = True
    End If
End If
End Sub

L'effacement se trouve dans un module

Sub raz(ok As Boolean)
    For Each f In Worksheets
    If IsNumeric(Left(f.Name, 1)) Then
        derL = f.Range("A" & Rows.Count).End(xlUp).Row
        f.Range("B11:AF" & derL).Clear
    End If
    Next
End Sub

Enfin le module qui compile les feuilles mensuelles, c'est le cœur du sujet

Sub COMPILER(ok As Boolean)
Dim f As Worksheet, tbl, bdd As Worksheet, fam As Object, result()

    ' raz de la bas de données
    Set bdd = Sheets("Recap")
    If Not bdd.ListObjects(1).DataBodyRange Is Nothing Then bdd.ListObjects(1).DataBodyRange.Delete

    ' chargement des familles de code
    cod = Range("Tcodes[#All]").Value
    Set fam = CreateObject("Scripting.Dictionary")
    For i = LBound(cod) + 1 To UBound(cod)
        fam(cod(i, 1)) = cod(i, 3)
    Next

    n = 0
    For Each f In Worksheets
    If IsNumeric(Left(f.Name, 1)) Then

        derL = f.Range("A" & Rows.Count).End(xlUp).Row
        tbl = f.Range("A8:AF" & derL).Value                              ' importation globale de la plage dans tbl

        For i = 4 To UBound(tbl) Step 3                                  ' ce qui donnera les noms en colonne 1
            For j = 2 To UBound(tbl, 2)                                  ' balayage de toutes les dates

                If tbl(i + 1, j) <> "" Then                              ' motif présent le matin
                    n = n + 1
                    ReDim Preserve result(1 To 9, 1 To n)
                    result(1, n) = tbl(i, 1)
                    result(2, n) = Format(tbl(1, j), "mm/dd/yyyy")
                    result(3, n) = tbl(i + 1, 1)
                    result(4, n) = tbl(i + 1, j)
                    result(5, n) = 0.5
                    result(6, n) = fam(tbl(i + 1, j))
                End If

                If tbl(i + 2, j) <> "" Then                              ' motif présent l'apm
                    n = n + 1
                    ReDim Preserve result(1 To 9, 1 To n)
                    result(1, n) = tbl(i, 1)
                    result(2, n) = Format(tbl(1, j), "mm/dd/yyyy")
                    result(3, n) = tbl(i + 2, 1)
                    result(4, n) = tbl(i + 2, j)
                    result(5, n) = 0.5
                    result(6, n) = fam(tbl(i + 2, j))
                End If

            Next
        Next

    End If
    Next

    bdd.Cells(2, 1).Resize(UBound(result, 2), UBound(result)) = Application.Transpose(result)

End Sub

Après, il s'agit d'une question d'organisation des données. Pratiquement pas de formules. Quelques MFC.

Le 28/10/2020 à 17:03
Steelson a écrit :
Anthony.w a écrit :

Ca me vas bien, j'ai modifié un peu la macro pour l'adapter à mes fichiers,

Merci !

Modifie r =  mais le reste laisse le en l'état !

pour le point 1, avec les vacances scolaires (2019/2020 et 2020/2021)

17planning-v3.xlsm (214.61 Ko)

C'est parfait, une question quand même Tu as utilisé un code ? Une mise en forme conditionnelle ? J'ai beau chercher je ne trouve pas dans le fichier…

Le 28/10/2020 à 17:19

une MFC

mais en fait je l'ai codée pour la dupliquer facilement sur toutes les pages, sinon c'est fastidieux !

normalement la MFC ne disparait pas ensuite

Private Sub Workbook_SheetActivate(ByVal f As Object)

If Not IsNumeric(Left(f.Name, 1)) Then Exit Sub

derL = f.Range("A" & Rows.Count).End(xlUp).Row
f.Cells.FormatConditions.Delete

With f.Range("B8:AF" & derL)
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=JOURSEM(B$8;2)>5"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
    End With
    .FormatConditions(1).StopIfTrue = False

    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=NB.SI(_JF;B$8)"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.799981688894314
    End With
    .FormatConditions(1).StopIfTrue = False

    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=ANNEE(B$8)<>$A$4"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.14996795556505
    End With
    .FormatConditions(1).StopIfTrue = False
End With

With f.Range("B10:AF" & derL)
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=JOURSEM(B$8;2)=7"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Borders(xlRight)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    .FormatConditions(1).StopIfTrue = False
End With

' vacances scolaires
With f.Range("B5:AF5")
    .FormatConditions.Add Type:=xlExpression, Formula1:="=SOMMEPROD((deA<=B$9)*(aA>B$9))>0"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599963377788629
    End With
    .FormatConditions(1).StopIfTrue = False
End With

With f.Range("B6:AF6")
    .FormatConditions.Add Type:=xlExpression, Formula1:="=SOMMEPROD((deB<=B$9)*(aB>B$9))>0"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599963377788629
    End With
    .FormatConditions(1).StopIfTrue = False
End With

With f.Range("B7:AF7")
    .FormatConditions.Add Type:=xlExpression, Formula1:="=SOMMEPROD((deC<=B$9)*(aC>B$9))>0"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.599963377788629
    End With
    .FormatConditions(1).StopIfTrue = False
End With

End Sub
Le 29/10/2020 à 09:53

Re Steelson, j'ai copier ta macro ici :

image

J'ai bien remplacé l'enseigne macro, qui donne le format des jours férié, par contre pour les vacances rien ne change.

image

J'ai aussi rajouté ce tableau mais pas de changement sur les onglets (Onglet "Calendrier", même cellule, même ligne).

Une idée ?

Le 29/10/2020 à 10:17

Si tu as exporté le tableau, alors il faut aussi nommer les zones

Tu peux le faire rapidement avec ceci en te mettant sur l'onglet Calendrier.

Sub vacances()
    On Error Resume Next
    With ActiveWorkbook.Names
        .Add Name:="deA", RefersToR1C1:="=Calendrier!R2C9:R16C9"
        .Add Name:="aA", RefersToR1C1:="=Calendrier!R2C10:R16C10"
        .Add Name:="deB", RefersToR1C1:="=Calendrier!R2C11:R16C11"
        .Add Name:="aB", RefersToR1C1:="=Calendrier!R2C12:R16C12"
        .Add Name:="deC", RefersToR1C1:="=Calendrier!R2C13:R16C13"
        .Add Name:="aC", RefersToR1C1:="=Calendrier!R2C14:R16C14"
    End With
End Sub

J'espère aussi au passage que tu as défusionné toutes les lignes 5/6/7 des onglets mensuels

Le 29/10/2020 à 11:00

Parfait, ça marche !

Oui façon j'ai pris comme basse ton fichier, et j'ai remplacé par mes données. Il me reste juste à bloquer certain paramètre tel que : Le déplacement des onglets, le changement d'années.

Ecoute on arrive au bout, en tout cas merci beaucoup de ton aide de ta patience et de ta sympathie !

Le 29/10/2020 à 11:57

Merci pour tes retours, c'est aussi très agréable de travailler avec quelqu'un de réactif et à l'écoute.

Tu peux solder le fil en cliquant sur V

Cela n'empêche pas qu'en cas de besoin tu peux revenir ici ou en mp.

Michel

Rechercher des sujets similaires à "calculateur absence fichiers"