XL 2021 Création calendrier ( Agenda ) en VBA

[Nicolas JACQUIN]

Bonjour à tous,

Je reviens avec mon calendrier pour le remettre un peu à jour.
Le but de mon projet est de partir d'une feuille vierge, de lancer la macro et que le calendrier se créé automatiquement,
avec :

- Paramétrage des heures de travail, matin et après midi (opérationnelle)
- Paramétrage des jours de repos (opérationnelle)
- Éphéméride pour chaque jours (opérationnelle)
- Lunaison (Plus qu'à adapter)

Mon (mes) Problème(s)

-Repérer les n° de semaine (ok), mais faire fusionner chaque groupe de n° de semaine (.MergeCells) ça match pas à la fin (j'ai plus ou moins réussi mais ça ne s'arrete pas sur la dernière colonne comme je voudrai), voir ci-dessous.

#job75 en premier m'avais proposé quelque chose qui fonctionnait, mais je n'arrive pas à l'adapter (module dans le fichier ci-dessous)
#Patrick aussi mais le code ne fonctionne pas (module dans le fichier ci-dessous)

J'ai déjà eu plusieurs critiques (date en format texte, ......) , mais je veux que se soit en vba, je suis autodidacte, pour moi c'est juste pour le plaisir d'apprendre (j'avoue que j'ai un peu de mal et que je bricole pas mal des fois).

Donc si vous pouvez m'aiguiller ou me simplifier le code tout en ayant le même résultat.
Quand j'ai un peu de temps je bricole un peu, donc soyez indulgent sur les critiques.
En vous remerciant d'avance.
Nicolas

 

[TooFatBoy]

Bonjour,

J'ai déjà eu plusieurs critiques (date en format texte, ......)

Je dirais plutôt "remarque" que "critique", car jusque là c'est déjà un joli travail et un bon résultat, surtout pour un autodidacte. 😉

 

[Nicolas JACQUIN]

Bonjour,


Je dirais plutôt "remarque" que "critique". 😉

Bonjour, c'était pas pour toi 😉

 

[TooFatBoy]

Tu veux avoir un mois (du 1er au dernier jour dudit mois) par feuille ?

Tu veux que le tableau se termine pile sur le dernier jour du mois, ou tu acceptes de faire tous les tableaux mensuels sur 31 jours et masquer les jours superflus ?

 

[Nicolas JACQUIN]

Pour l'instant je l'ai réactualisé un peu mieux qu'il n'était,
Pour la question, oui, je veux créer un mois entier, et par la suite créer une macro pour l'enregistrer dans un nouvel onglet avec comme comme nom d'onglet le mois et année, mais ça ça va aller.
Faut que ce soit comme là, du 1er au dernier jour du mois, se qui me bloque c'est comme mon dernier post fusionner les n° semaines, qu'il n'y est pas de dépacement du dernier jour du mois concerné.
J'espère que je suis compréhensif dans mon histoire 😀

Edit, Je l'ai aussi en année complète, je veux juste que se soit propre aussi bien niveau code que finition.

Merci

 

[TooFatBoy]

Une double proposition (avec, ou sans, fusion de cellules) :

Sub Essai()
'
    Call Essai_01(2024, 2)
    Call Essai_02(2024, 2)

End Sub

Sub Essai_01(Annee As Integer, Mois As Integer)
'
Dim NbJoursMois As Integer, i As Integer, j As Integer

    NbJoursMois = Day(DateSerial(Annee, Mois + 1, 0))

    ' Coloriage du premier au dernier jour du mois
    With Range("B1").Resize(1, NbJoursMois)
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        .Interior.Color = RGB(204, 255, 255)
    End With

    ' Fusion des semaines du mois
    i = 1
    While i <= NbJoursMois
        If i = 1 Or Weekday(DateSerial(Annee, Mois, i), vbMonday) = 1 Then
            Cells(1, 1 + i).Value = "Semaine " & Application.IsoWeekNum(DateSerial(Annee, Mois, i))
            j = i
        End If
        If i = NbJoursMois Or Weekday(DateSerial(Annee, Mois, i), vbMonday) = 7 Then
            With Range(Cells(1, 1 + j), Cells(1, 1 + i))
                .Merge
                .HorizontalAlignment = xlCenter
            End With
        End If
        i = i + 1
    Wend

End Sub

Sub Essai_02(Annee As Integer, Mois As Integer)
'
Dim NbJoursMois As Integer, i As Integer

    NbJoursMois = Day(DateSerial(Annee, Mois + 1, 0))

    ' Coloriage du premier au dernier jour du mois
    With Range("B3").Resize(1, NbJoursMois)
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        .Interior.Color = RGB(204, 255, 255)
        .HorizontalAlignment = xlCenterAcrossSelection
    End With

    ' Écriture des lundis
    For i = 1 To NbJoursMois
        If i = 1 Or Weekday(DateSerial(Annee, Mois, i), vbMonday) = 1 Then
            Cells(3, 1 + i).Value = "Semaine " & Application.IsoWeekNum(DateSerial(Annee, Mois, i))
        End If
    Next i

End Sub

 

[Nicolas JACQUIN]

Une double proposition (avec, ou sans, fusion de cellules) :

Bonjour, merci pour ton bout de code, intégré facilement.
merci beaucoup
Nicolas

        i = 1
        While i <= nbjour
            If i = 1 Or Weekday(DateSerial(année, mois, i), vbMonday) = 1 Then
                Cells(1, 1 + i).Value = "Semaine " & Application.IsoWeekNum(DateSerial(année, mois, i))
                j = i
            End If
            If i = nbjour Or Weekday(DateSerial(année, mois, i), vbMonday) = 7 Then
                With Range(Cells(1, 1 + j), Cells(1, 1 + i))
                    .Merge
                    .HorizontalAlignment = xlCenter
                End With
            End If
            i = i + 1
        Wend

 

[Nicolas JACQUIN]

ça fini bien maintenant, au top

 

[TooFatBoy]

Comme tu l'as sûrement remarqué, perso j'évite les lettres accentuées dans les noms de variables, car ça peut poser des problèmes. 😉

De même, j'évite aussi les fusions de cellules autant que faire se peut car ça risque de poser des problèmes, en particulier en cas de copier/coller.
D'où les deux propositions de #6.


Tu as maintenant un bel agenda mensuel, taillé sur mesure, au pixel près. 👏

 

[Nicolas JACQUIN]

Voici ou j'en suis pour l'instant.
Si vous avez des améliorations à suggérer, je suis à l'écoute

Public Const Synod = 29.530588861
Public Const BaseNewMoonDateString As String = "2024-05-07 23:22"

Sub test()
    Agenda 2024, 5  'année puis mois
End Sub

Function Agenda(année, mois)
    Dim i As Long, l As Long, col As Long, lig As Long, nbjour As Long, j, x, k, Jférié, Jfériéstring, 

    Application.DisplayAlerts = False: Application.ScreenUpdating = False

    With Worksheets("Feuil1")

        Cells.Delete

                Cells(lig, col + 1).AddComment
                Cells(lig, col + 1).Comment.Text Text:="Pleine lune"
            End If
            If Cells(lig, col) = 4 Then
                Cells(lig, col).AddComment
                Cells(lig, col).Comment.Text Text:="Dernier quart de lune"
            End If
            col = col + 1
        Next i

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""""""" Base jour """"""""""""""""""""""""""""""""""""""""""""""""""""""""

        lig = 2: col = 2
        For i = 1 To nbjour
            .Cells(lig, col).Font.Size = 14
            .Cells(lig - 1, col).Font.Size = 14
            .Range(Cells(lig - 1, col), Cells(lig + 1, col)).Font.Bold = True
            .Range(Cells(lig, col), Cells(lig + 1, col)).HorizontalAlignment = xlCenter
            .Cells(lig, col) = WorksheetFunction.Proper(Format(DateSerial(année, mois, i), "dddd"))
            .Cells(lig + 1, col) = (Format(DateSerial(année, mois, i), "dd" & " " & "mmmm" & " " & année))
            col = col + 1
        Next i

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '""""""""""""""""""""""""""""""""""""""""""" N° de semaine Fusion """"""""""""""""""""""""""""""""""""""""""""""""""

        i = 1
        While i <= nbjour
            If i = 1 Or Weekday(DateSerial(année, mois, i), vbMonday) = 1 Then
                Cells(1, 1 + i).Value = "Semaine " & Application.IsoWeekNum(DateSerial(année, mois, i))
                j = i
            End If
            If i = nbjour Or Weekday(DateSerial(année, mois, i), vbMonday) = 7 Then
                With Range(Cells(1, 1 + j), Cells(1, 1 + i))
                    .Merge
                    .HorizontalAlignment = xlCenter
                End With
            End If
            i = i + 1
        Wend

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""" Heures de travail """"""""""""""""""""""""""""""""""""""""""""""""""""

        HdebAM = Worksheets("Paramètre").Range("C3").Value: HfinAM = Worksheets("Paramètre").Range("C4").Value
        HdebPM = Worksheets("Paramètre").Range("C5").Value: HfinPM = Worksheets("Paramètre").Range("C6").Value
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column

        lig = 4: col = 1
        For i = HdebAM To HfinAM ' Matin
            .Cells(lig, col) = HdebAM
        dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(Cells(lig + 2, 2), Cells(lig + 2, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            .Range(Cells(lig, 2), Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot

            lig = lig + 2: HdebPM = HdebPM + 1
        Next

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '""""""""""""""""""""""""""""""""""""""""""" Coloriage des jours """""""""""""""""""""""""""""""""""""""""""""""""""

        derlig = .Range("A" & Rows.Count).End(xlUp).Row
        dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
        lig = 2: col = 2
        For i = 1 To nbjour

            'Coloriage ligne n° semaine
            .Cells(lig - 1, col).Interior.ColorIndex = 20

            'Coloriage jours
            .Range(Cells(lig, col), Cells(lig + 1, col)).Interior.ColorIndex = 20

            'Coloriage jours chomés
            m = 10 ' Range G, ligne 5 dans la feuille paramètre
            For h = 1 To 7 ' choix de 7 jours dans la feuille paramètre
                If Worksheets("Paramètre").Range("E" & m).Value = True And Weekday(DateSerial(année, mois, i), vbMonday) = Worksheets("Paramètre").Range("F" & m).Value Then
                    .Range(Cells(lig, col), Cells(derlig + 1, col)).Interior.ColorIndex = 20
                End If
                m = m + 1
            Next h

            'Coloriage férié
            For j = 0 To UBound(Jférié)
                If CDate(Jférié(j) & année) = DateSerial(année, mois, i) Then
                    .Range(Cells(lig, col), Cells(derlig + 1, col)).Interior.ColorIndex = 35
                    Cells(lig, col).Interior.ColorIndex = 35
                    Cells(lig + 2, col) = Jfériéstring(j)
                    Cells(lig + 2, col).HorizontalAlignment = xlCenter
                    Cells(lig + 2, col).Font.Bold = True
                End If
            Next j

            If année = Year(Date) And mois = Month(Date) And i = Day(Date) Then
                .Range(Cells(lig, col), Cells(lig + 1, col)).Interior.ColorIndex = 28 'Coloriage aujourd'hui
                'ActiveWindow.ScrollColumn = i + 1     'va à la colonne
            End If

            'Coloriage fête
            For k = 0 To UBound(Jfete)
                If CDate(Jfete(k) & année) = DateSerial(année, mois, i) Then
                    Cells(lig + 2, col) = Jfetestring(k)
                    Cells(lig + 2, col).HorizontalAlignment = xlCenter
                End If
            Next k

            .Cells(derlig + 2, col) = "Fêtes à souhaiter" & " :  "
            .Cells(derlig + 2, col).Interior.ColorIndex = 36
            .Cells(derlig + 2, col).Font.Size = 11
            .Rows(derlig + 3).RowHeight = 80
            .Cells(derlig + 3, col).HorizontalAlignment = xlCenter
            .Cells(derlig + 3, col).VerticalAlignment = xlCenter
            .Cells(derlig + 3, col).Font.Bold = True

            col = col + 1

        Next i

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '""""""""""""""""""""""""""""""""""""""""""" Quadrillage Agenda """"""""""""""""""""""""""""""""""""""""""""""""""""

        .Range(Cells(2, 2), Cells(3, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
        .Range(Cells(2, 2), Cells(3, dercol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Range(Cells(2, 2), Cells(3, dercol)).Borders(xlEdgeRight).LineStyle = xlContinuous
        .Range(Cells(2, 2), Cells(3, dercol)).Borders(xlInsideVertical).LineStyle = xlContinuous

        .Range(Cells(4, 2), Cells(derlig + 1, dercol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Range(Cells(4, 2), Cells(derlig + 1, dercol)).Borders(xlEdgeRight).LineStyle = xlContinuous
        .Range(Cells(4, 2), Cells(derlig + 1, dercol)).Borders(xlInsideVertical).LineStyle = xlContinuous

        .Range(Cells(1, 1), Cells(derlig + 3, 1)).Interior.ColorIndex = 20 'Colonne heures
        .Range(Cells(derlig + 3, 1), Cells(derlig + 3, dercol)).Interior.ColorIndex = 20 'Ligne fêtes

        .Range(Cells(derlig + 2, 1), Cells(derlig + 3, dercol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Range(Cells(derlig + 2, 1), Cells(derlig + 3, dercol)).Borders(xlEdgeRight).LineStyle = xlContinuous
        .Range(Cells(derlig + 2, 1), Cells(derlig + 3, dercol)).Borders(xlInsideVertical).LineStyle = xlContinuous
        .Range(Cells(derlig + 3, 1), Cells(derlig + 3, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous

        .Range(Cells(1, 2), Cells(1, dercol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Range(Cells(1, 2), Cells(1, dercol)).Borders(xlEdgeRight).LineStyle = xlContinuous
        .Range(Cells(1, 2), Cells(1, dercol)).Borders(xlInsideVertical).LineStyle = xlContinuous
        .Range(Cells(1, 2), Cells(1, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""""""" Éphéméride  """"""""""""""""""""""""""""""""""""""""""""""""""""""

        derlig = .Range("A" & Rows.Count).End(xlUp).Row
        .Columns("A").ColumnWidth = 5
        .Columns("B:AG").ColumnWidth = 20

        col = 2
        For i = 1 To nbjour
            FetePren = ""
            x = 0
            Do While Range("FichFetes!C1").Offset(x, 0) <> ""
                If Range("FichFetes!A1").Offset(x, 0) = i And Range("FichFetes!B1").Offset(x, 0) = mois Then
                    FetePren = FetePren & Range("FichFetes!C1").Offset(x, 0) & ", "
                End If
                x = x + 1
            Loop
            If FetePren <> "" Then
                .Cells(derlig + 3, col) = chr(10) & Mid(FetePren, 1, Len(FetePren) - 2) & chr(10) & chr(10)
            Else
                .Cells(derlig + 3, col) = ""
            End If
            col = col + 1
        Next
    End With

    With ActiveWindow: .SplitColumn = 1: .SplitRow = 3: End With: ActiveWindow.FreezePanes = True

End Function


Sub Actualisation()

    année = Year(Date)
    mois = Month(Date)

    Actu_jour année, mois

End Sub

Function Actu_jour(année, mois)

    Application.ScreenUpdating = False
    Dim i As Long, nbjour As Long
 
    nbjour = Day(DateSerial(année, mois + 1, 0)) ' te donne le nombre de jour dans le mois en parametre
 
    lig = 2: col = 2
    With Worksheets("Feuil1")
        For i = 1 To nbjour
            If année = Year(Date) And mois = Month(Date) And i = Day(Date) Then
                .Range(Cells(lig, col), Cells(lig + 1, col)).Interior.ColorIndex = 28 'Coloriage aujourd'hui
                ActiveWindow.ScrollColumn = i + 1     'va à la colonne aujourd'hui
            End If
            col = col + 1
        Next i
    End With
 
End Function

Public Function PhaseLunaire(dDate As Date) As Integer

    Select Case AgeLune(dDate)

        Case Is > Synod - 1 'Nouvelle lune
            PhaseLunaire = 1
        
        Case Synod / 4 - 1 To Synod / 4 '1/4 de lune
            PhaseLunaire = 2
        
        Case Synod / 2 - 1 To Synod / 2 'Pleine lune
            PhaseLunaire = 3
        
        Case 3 * Synod / 4 - 1 To 3 * Synod / 4 '3/4 de lune
            PhaseLunaire = 4
        
        Case Else 'Lune noir
            PhaseLunaire = 0
    End Select
 
End Function

Public Function AgeLune(dDate As Date) As Single

    Dim BaseDate As Date

    BaseDate = CDate(BaseNewMoonDateString)
    AgeLune = REMAINDER((dDate - BaseDate), Synod)

End Function

Public Function REMAINDER(Number As Variant, DivideBy As _
                          Variant) As Variant

    If Number = 0 Then REMAINDER = 0 Else REMAINDER = Number - DivideBy * Int(Number / DivideBy)

End Function

Pour la phase lunaire j'ai intégré un tout pitit bout, je sais pas encore, je veux pas faire une usine à gaz non plus.
Merci

 

[ChTi160]

Bonjour le Fil ,
histoire de participer Lol
ce que j'ai modifié:

 Dim Cmt As Comment
    Dim StrComment$
    Set Cmt = Nothing
    StrComment$ = ""
    lig = 3: Col = 2
    For I = 1 To Nbjour
        With Cells(lig, Col)
            .Value = PhaseLunaire(DateSerial(année, mois, I))
            Select Case .Value
                Case 1
                    StrComment = "Nouvel lune"
                Case 2
                    StrComment$ = "1er quart de lune"
                Case 3
                    StrComment$ = "Pleine lune"
                Case 4
                    StrComment$ = "Dernier quart de lune"
            End Select
            Set Cmt = .AddComment
            Cmt.Text Text:=StrComment

        End With
        Col = Col + 1
    Next I

Bonne Journée
Jean marie

 

[Nicolas JACQUIN]

Bonjour Jean marie, je c'est pas si tu as essayé dans ma fonction, mais y a un petit problème.
C'est pleine lune tout les jours, c'est pas que ça me dérangerai 🤣🤣🤣🤣

Merci de vous y interesser
Nicolas

 

[Nicolas JACQUIN]

Sinon pour faire plus simple, j'affiche que les jours de pleine-lune, ça chargera beaucoup moins

 

[ChTi160]

Re
ce que j'ai modifié :

   '""""""""""""""""""""""""""""""""""""""""""""""" Phase lunaire  """"""""""""""""""""""""""""""""""""""""""""""""""""

        lig = 3: col = 2
    Dim Cmt As Comment
    Dim StrComment$
    Set Cmt = Nothing
    StrComment$ = ""
    lig = 3: col = 2
    For i = 1 To nbjour
        With Cells(lig, col)
            .Value = PhaseLunaire(DateSerial(année, mois, i))
          
            Select Case .Value
                Case 1
                    StrComment = "Nouvel lune"
                Case 2
                    StrComment$ = "1er quart de lune"
                Case 3
                    StrComment$ = "Pleine lune"
                Case 4
                    StrComment$ = "Dernier quart de lune"
            End Select
            If StrComment <> "" Then
                  Set Cmt = .AddComment
                        Cmt.Text Text:=StrComment
                        With Cmt.Shape
                             .Width = 100   ' Largeur en points
                             .Height = 12 ' Hauteur en points
                        End With
            End If
        End With
        col = col + 1
                             Set Cmt = Nothing
                    StrComment$ = ""
    Next i

Jean marie

 

[Nicolas JACQUIN]

Merci, ça marche 😉