XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook

Nicolas JACQUIN

XLDnaute Occasionnel
Supporter XLD
Bonjour à tous,
Toujours avec mon agenda, j'ai un bouton pour créer l'agenda souhaité qui fonctionne,
et (mais la je beug) un bouton pour exporter l'agenda dans un nouveau classeur, le renommer au nom de l'agenda créé, mais je voudrais pouvoir le faire depuis une msgbox yes no
(si oui créer nouveau classeur avec module Thisworkbook, si non laisser tel que c'est dans le classeur actuel)
Encore un petit soucis à régler sur l'actualisation au démarrage aussi.
J'espère être asse compréhensif dans mes demandes, si toutefois il y aurait des améliorations (sans aucun doute) je suis preneur
En vous remerciant d'avance.
Nicolas

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

Sub Creation1()
    With ThisWorkbook.Worksheets("Paramètre")
        Agenda1 .[B3].Value, Month(CDate("1 " & .[C3].Value & " " & .[B3].Value))
    End With
End Sub

Function Agenda1(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, Jfetestring, Jfete, coulférié, lpaques, Paques, pentecote, lunpentecote, ascension, Jfête, Jfêtestring
    Dim derlig As Integer, dercol As Integer, paque As Date, Cmt As Comment, StrComment$
    Dim WsP As Worksheet, fc As Worksheet
    Set WsP = ThisWorkbook.Worksheets("Paramètre")
    paque = CDate(((Round(DateSerial(année, 4, (234 - 11 * (année Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    Paques = Format(paque, "dd/mm/")
    lpaques = Format(CDate(Paques & année) + 1, "dd/mm/")
    mardigras = Format(CDate(Paques & année) - 47, "dd/mm/")
    rameau = Format(CDate(Paques & année) - 7, "dd/mm/")
    vendredisaint = Format(CDate(Paques & année) - 2, "dd/mm/")
    ascension = Format(CDate(Paques & année) + 39, "dd/mm/")
    pentecote = Format(CDate(Paques & année) + 49, "dd/mm/")
    lunpentecote = Format(CDate(Paques & année) + 50, "dd/mm/")

    Jférié = Array("25/12/", "01/01/", lpaques, ascension, pentecote, lunpentecote, IIf(année > 1973, "01/05/", ""), IIf(année > 1944, "08/05/", ""), "14/07/", "15/08/", "01/11/", "11/11/")
    Jfériéstring = Array("Noël ", "Jour de l'An", "Lundi de Pâques ", "Ascension", "Pentecôte ", "Lundi de Pentecôte", _
                          IIf(année > 1973, "Fête du travail", ""), IIf(année > 1944, "Victoire 1945", ""), "Fête Nationale", "Assomption", "Toussaint", "Armistice 1918")
    Jfete = Array(mardigras, rameau, vendredisaint, "14/02/", Paques): Jfetestring = Array("Mardi-Gras", "Rameaux", "Vendredi Saint", "St Valentin ", "Pâques ")
    nbjour = Day(DateSerial(année, mois + 1, 0)) 'nombre de jour dans le mois en parametre

    Application.DisplayAlerts = False: Application.ScreenUpdating = False

    '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
    '"""""""""""""""""""""""""""""""""""""""" Vérifie si mois existe ou pas """"""""""""""""""""""""""""""""""""""""""""

    For Each fc In ActiveWorkbook.Worksheets
        With Worksheets("Paramètre")
            If fc.Name = .Range("C3") & "_" & .Range("B3") Then
                MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "existe déjà", , "Regardez mieux"
                Exit Function
            End If
        End With
    Next fc

    With Worksheets("Feuil1")

        .Cells.Delete

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

        lig = 3: col = 2
        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: .Height = 12: End With
                End If
            End With
            col = col + 1
            Set Cmt = Nothing
            StrComment$ = ""
        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

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""" Fusion Numéro de semaine """""""""""""""""""""""""""""""""""""""""""""""

        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 = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column

        lig = 3: col = 1
        For i = HdebAM To HfinAM ' Matin
            With .Cells(lig, col)
                .Value = HdebAM
                .Font.Size = 12
                .Font.Bold = True
            End With
            .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
            .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot
            lig = lig + 2: HdebAM = HdebAM + 1
        Next

        .Range(.Cells(lig - 1, 1), .Cells(lig + 2, dercol)).Interior.ColorIndex = 24 ' pose
        .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True

        With .Cells(lig, 1)
            .Value = "Pose"
            .Font.Bold = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeTop).LineStyle = xlNone

        lig = lig + 2
        For i = HdebPM To HfinPM ' Après-midi

            With .Cells(lig, col)
                .Value = HdebPM
                .Font.Size = 12
                .Font.Bold = True
            End With
            .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
            .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 1), .Cells(lig + 1, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot
            lig = lig + 2: HdebPM = HdebPM + 1
        Next

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

        HdebAM = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        Ham = (HfinAM - HdebAM) * 2: Hap = (HfinPM - HdebPM) * 2
        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 = 24

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

            'Coloriage jours chomés
            m = 14
            For l = 1 To 7
                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 + 2, col), .Cells(lig + 1 + Ham, col)).Interior.ColorIndex = 39
                End If
                m = m + 1
            Next l
            .Range(.Cells(lig + 2 + Ham, col), .Cells(derlig - Hap, col)).Interior.ColorIndex = 39
            n = 14
            For s = 1 To 7
                If Worksheets("Paramètre").Range("G" & n).Value = True And Weekday(DateSerial(année, mois, i), vbMonday) = Worksheets("Paramètre").Range("H" & n).Value Then
                    .Range(.Cells(derlig, col), .Cells(derlig + 1 - Hap, col)).Interior.ColorIndex = 39
                End If
                n = n + 1
            Next s

            '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 + 2, col), .Cells(derlig, col)).Interior.ColorIndex = 39

                    With .Range(.Cells(lig + 2 + Ham, col), .Cells(lig + 4 + Ham + 1, col))
                        .MergeCells = True
                        .Font.Size = 12
                        .VerticalAlignment = xlCenter
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With

                    .Cells(lig + 2 + Ham, col) = Jfériéstring(j)

                    With .Cells(lig + 2, col)
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With

                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

                    With .Cells(lig + 2, col)
                        .Value = Jfetestring(k)
                        .HorizontalAlignment = xlCenter
                    End With

                End If
            Next k

            With .Cells(derlig + 3, col)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With

            col = col + 1

        Next i

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

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

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

        With .Range(.Cells(1, 1), .Cells(derlig + 2, 1))
            .Interior.ColorIndex = 24 'Colonne heures
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        .Range(.Cells(derlig + 1, 1), .Cells(derlig + 2, dercol)).Interior.ColorIndex = 24 'Ligne notes

        With .Range(.Cells(derlig + 3, 1), .Cells(derlig + 3, dercol))
            .Interior.ColorIndex = 35 'Ligne fêtes
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
        End With

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

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

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""""""" É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

        derlign = .Range("B" & Rows.Count).End(xlUp).Row
        .Range(.Cells(derlign - 1, 1), .Cells(derlign - 1, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Rows(derlig + 2).RowHeight = 80
        .Rows(derlig + 3).RowHeight = 80

        With .Cells(derlig + 2, 1)
            .Value = "Note"
            .Orientation = xlVertical
            .VerticalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
        End With

        .Range(.Cells(derlign - 1, 2), .Cells(derlign - 1, dercol)).Borders(xlEdgeTop).LineStyle = xlNone

        With .Cells(derlig + 3, 1)
            .Value = "Fête"
            .Orientation = xlVertical
            .VerticalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
        End With

    End With

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

    With Worksheets("Paramètre")
        Worksheets("Feuil1").Name = .Range("C3") & "_" & .Range("B3")
        Sheets.Add(Before:=Sheets(1)).Name = "Feuil1"
        .Activate
        MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "a été créé", , "Bravo !!!!!"
    End With
   
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
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            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

Capture d’écran 2024-06-02 123525.jpg
 

Pièces jointes

  • Agenda v22.xlsm
    86.3 KB · Affichages: 6
Dernière édition:

TooFatBoy

XLDnaute Barbatruc
Je veux dire que, si j'ai bien compris le fonctionnement de ta fonction REMAINDER, elle n'est pas utile car elle calcule simplement la congruence d'un nombre modulo un autre nombre, et la fonction mathématique modulo existe en VBA.


Oui, je sais ça n'a aucun rapport avec la question que tu poses au départ. C'est juste une remarque. 😔
 

Gégé-45550

XLDnaute Accro
Bonjour à tous,
Toujours avec mon agenda, j'ai un bouton pour créer l'agenda souhaité qui fonctionne,
et (mais la je beug) un bouton pour exporter l'agenda dans un nouveau classeur, le renommer au nom de l'agenda créé, mais je voudrais pouvoir le faire depuis une msgbox yes no
(si oui créer nouveau classeur avec module Thisworkbook, si non laisser tel que c'est dans le classeur actuel)
Encore un petit soucis à régler sur l'actualisation au démarrage aussi.
J'espère être asse compréhensif dans mes demandes, si toutefois il y aurait des améliorations (sans aucun doute) je suis preneur
En vous remerciant d'avance.
Nicolas

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

Sub Creation1()
    With ThisWorkbook.Worksheets("Paramètre")
        Agenda1 .[B3].Value, Month(CDate("1 " & .[C3].Value & " " & .[B3].Value))
    End With
End Sub

Function Agenda1(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, Jfetestring, Jfete, coulférié, lpaques, Paques, pentecote, lunpentecote, ascension, Jfête, Jfêtestring
    Dim derlig As Integer, dercol As Integer, paque As Date, Cmt As Comment, StrComment$
    Dim WsP As Worksheet, fc As Worksheet
    Set WsP = ThisWorkbook.Worksheets("Paramètre")
    paque = CDate(((Round(DateSerial(année, 4, (234 - 11 * (année Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    Paques = Format(paque, "dd/mm/")
    lpaques = Format(CDate(Paques & année) + 1, "dd/mm/")
    mardigras = Format(CDate(Paques & année) - 47, "dd/mm/")
    rameau = Format(CDate(Paques & année) - 7, "dd/mm/")
    vendredisaint = Format(CDate(Paques & année) - 2, "dd/mm/")
    ascension = Format(CDate(Paques & année) + 39, "dd/mm/")
    pentecote = Format(CDate(Paques & année) + 49, "dd/mm/")
    lunpentecote = Format(CDate(Paques & année) + 50, "dd/mm/")

    Jférié = Array("25/12/", "01/01/", lpaques, ascension, pentecote, lunpentecote, IIf(année > 1973, "01/05/", ""), IIf(année > 1944, "08/05/", ""), "14/07/", "15/08/", "01/11/", "11/11/")
    Jfériéstring = Array("Noël ", "Jour de l'An", "Lundi de Pâques ", "Ascension", "Pentecôte ", "Lundi de Pentecôte", _
                          IIf(année > 1973, "Fête du travail", ""), IIf(année > 1944, "Victoire 1945", ""), "Fête Nationale", "Assomption", "Toussaint", "Armistice 1918")
    Jfete = Array(mardigras, rameau, vendredisaint, "14/02/", Paques): Jfetestring = Array("Mardi-Gras", "Rameaux", "Vendredi Saint", "St Valentin ", "Pâques ")
    nbjour = Day(DateSerial(année, mois + 1, 0)) 'nombre de jour dans le mois en parametre

    Application.DisplayAlerts = False: Application.ScreenUpdating = False

    '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
    '"""""""""""""""""""""""""""""""""""""""" Vérifie si mois existe ou pas """"""""""""""""""""""""""""""""""""""""""""

    For Each fc In ActiveWorkbook.Worksheets
        With Worksheets("Paramètre")
            If fc.Name = .Range("C3") & "_" & .Range("B3") Then
                MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "existe déjà", , "Regardez mieux"
                Exit Function
            End If
        End With
    Next fc

    With Worksheets("Feuil1")

        .Cells.Delete

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

        lig = 3: col = 2
        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: .Height = 12: End With
                End If
            End With
            col = col + 1
            Set Cmt = Nothing
            StrComment$ = ""
        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

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""" Fusion Numéro de semaine """""""""""""""""""""""""""""""""""""""""""""""

        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 = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column

        lig = 3: col = 1
        For i = HdebAM To HfinAM ' Matin
            With .Cells(lig, col)
                .Value = HdebAM
                .Font.Size = 12
                .Font.Bold = True
            End With
            .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
            .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot
            lig = lig + 2: HdebAM = HdebAM + 1
        Next

        .Range(.Cells(lig - 1, 1), .Cells(lig + 2, dercol)).Interior.ColorIndex = 24 ' pose
        .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True

        With .Cells(lig, 1)
            .Value = "Pose"
            .Font.Bold = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeTop).LineStyle = xlNone

        lig = lig + 2
        For i = HdebPM To HfinPM ' Après-midi

            With .Cells(lig, col)
                .Value = HdebPM
                .Font.Size = 12
                .Font.Bold = True
            End With
            .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
            .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 1), .Cells(lig + 1, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot
            lig = lig + 2: HdebPM = HdebPM + 1
        Next

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

        HdebAM = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        Ham = (HfinAM - HdebAM) * 2: Hap = (HfinPM - HdebPM) * 2
        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 = 24

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

            'Coloriage jours chomés
            m = 14
            For l = 1 To 7
                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 + 2, col), .Cells(lig + 1 + Ham, col)).Interior.ColorIndex = 39
                End If
                m = m + 1
            Next l
            .Range(.Cells(lig + 2 + Ham, col), .Cells(derlig - Hap, col)).Interior.ColorIndex = 39
            n = 14
            For s = 1 To 7
                If Worksheets("Paramètre").Range("G" & n).Value = True And Weekday(DateSerial(année, mois, i), vbMonday) = Worksheets("Paramètre").Range("H" & n).Value Then
                    .Range(.Cells(derlig, col), .Cells(derlig + 1 - Hap, col)).Interior.ColorIndex = 39
                End If
                n = n + 1
            Next s

            '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 + 2, col), .Cells(derlig, col)).Interior.ColorIndex = 39

                    With .Range(.Cells(lig + 2 + Ham, col), .Cells(lig + 4 + Ham + 1, col))
                        .MergeCells = True
                        .Font.Size = 12
                        .VerticalAlignment = xlCenter
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With

                    .Cells(lig + 2 + Ham, col) = Jfériéstring(j)

                    With .Cells(lig + 2, col)
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With

                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

                    With .Cells(lig + 2, col)
                        .Value = Jfetestring(k)
                        .HorizontalAlignment = xlCenter
                    End With

                End If
            Next k

            With .Cells(derlig + 3, col)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With

            col = col + 1

        Next i

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

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

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

        With .Range(.Cells(1, 1), .Cells(derlig + 2, 1))
            .Interior.ColorIndex = 24 'Colonne heures
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        .Range(.Cells(derlig + 1, 1), .Cells(derlig + 2, dercol)).Interior.ColorIndex = 24 'Ligne notes

        With .Range(.Cells(derlig + 3, 1), .Cells(derlig + 3, dercol))
            .Interior.ColorIndex = 35 'Ligne fêtes
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
        End With

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

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

        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""""""" É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

        derlign = .Range("B" & Rows.Count).End(xlUp).Row
        .Range(.Cells(derlign - 1, 1), .Cells(derlign - 1, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Rows(derlig + 2).RowHeight = 80
        .Rows(derlig + 3).RowHeight = 80

        With .Cells(derlig + 2, 1)
            .Value = "Note"
            .Orientation = xlVertical
            .VerticalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
        End With

        .Range(.Cells(derlign - 1, 2), .Cells(derlign - 1, dercol)).Borders(xlEdgeTop).LineStyle = xlNone

        With .Cells(derlig + 3, 1)
            .Value = "Fête"
            .Orientation = xlVertical
            .VerticalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
        End With

    End With

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

    With Worksheets("Paramètre")
        Worksheets("Feuil1").Name = .Range("C3") & "_" & .Range("B3")
        Sheets.Add(Before:=Sheets(1)).Name = "Feuil1"
        .Activate
        MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "a été créé", , "Bravo !!!!!"
    End With
  
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
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            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

Regarde la pièce jointe 1198070
Bonjour,
Une possibilité :
VB:
Sub Creation1()
Dim Reponse
    Reponse = MsgBox("Créer l'agenda ?", vbYesNo, "Création nouvel agenda")
      If Reponse = vbNo Then
        Exit Sub
      ElseIf Reponse = vbYes Then
         With ThisWorkbook.Worksheets("Paramètre")
            Agenda1 .[B3].Value, Month(CDate("1 " & .[C3].Value & " " & .[B3].Value))
         End With
      End If
End Sub
Cordialement,
 

Gégé-45550

XLDnaute Accro
Bonjour Gégé-45550,
merci pour la réponse mais peut-être me suis-je mal exprimé,
ma question est, comment faire pour exporter l'aganda créé dans un nouveau classeur avec le module thisworkbook (qui faut que je reprenne aussi) avec msgbox vbyesno (bouton exporter)
Merci
Nicolas
Désolé mais ce n'est pas clair !
ThisWorkBook n'est pas un module mais une propriété de l'application Excel.
Votre fichier ne contient qu'un module baptisé "Agenda", est-ce celui-ci que vous voulez pouvoir choisir d'exporter ou non ?
 

Nicolas JACQUIN

XLDnaute Occasionnel
Supporter XLD
Désolé, si j'exporte, je veux que si on démarre un agenda, il s'actualise au jour d'aujourd'hui

VB:
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
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            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
 

Nicolas JACQUIN

XLDnaute Occasionnel
Supporter XLD
Désolé, si j'exporte, je veux que si on démarre un agenda, il s'actualise au jour d'aujourd'hui

VB:
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
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            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
C'est à retravailler sans doute, mais dans ce contexte
 

Nicolas JACQUIN

XLDnaute Occasionnel
Supporter XLD
Bonjour tout le monde,
Quelques modifications du rendu et du code, attend toujours vos retours sur l'exportation

VB:
Public Const Synod = 29.530588861
Public Const BaseNewMoonDateString As String = "2024-05-07 23:22"
Sub Creation1()
    Dim Reponse
    Reponse = MsgBox("Créer l'agenda ?", vbYesNo, "Création nouvel agenda")
    If Reponse = vbNo Then
        Exit Sub
    ElseIf Reponse = vbYes Then
        With ThisWorkbook.Worksheets("Paramètre")
            Agenda1 .[B3].Value, Month(CDate("1 " & .[C3].Value & " " & .[B3].Value))
        End With
    End If
End Sub
Function Agenda1(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, Jfetestring, Jfete, coulférié, lpaques, Paques, pentecote, lunpentecote, ascension, Jfête, Jfêtestring
    Dim derlig As Integer, dercol As Integer, paque As Date, Cmt As Comment, StrComment$
    Dim WsP As Worksheet, fc As Worksheet
    Set WsP = ThisWorkbook.Worksheets("Paramètre")
    paque = CDate(((Round(DateSerial(année, 4, (234 - 11 * (année Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    Paques = Format(paque, "dd/mm/")
    lpaques = Format(CDate(Paques & année) + 1, "dd/mm/")
    mardigras = Format(CDate(Paques & année) - 47, "dd/mm/")
    rameau = Format(CDate(Paques & année) - 7, "dd/mm/")
    vendredisaint = Format(CDate(Paques & année) - 2, "dd/mm/")
    ascension = Format(CDate(Paques & année) + 39, "dd/mm/")
    pentecote = Format(CDate(Paques & année) + 49, "dd/mm/")
    lunpentecote = Format(CDate(Paques & année) + 50, "dd/mm/")
    Jférié = Array("25/12/", "01/01/", lpaques, ascension, pentecote, lunpentecote, IIf(année > 1973, "01/05/", ""), IIf(année > 1944, "08/05/", ""), "14/07/", "15/08/", "01/11/", "11/11/")
    Jfériéstring = Array("Noël ", "Jour de l'An", "Lundi de Pâques ", "Ascension", "Pentecôte ", "Lundi de Pentecôte", _
                          IIf(année > 1973, "Fête du travail", ""), IIf(année > 1944, "Victoire 1945", ""), "Fête Nationale", "Assomption", "Toussaint", "Armistice 1918")
    Jfete = Array(mardigras, rameau, vendredisaint, "14/02/", Paques): Jfetestring = Array("Mardi-Gras", "Rameaux", "Vendredi Saint", "St Valentin ", "Pâques ")
    nbjour = Day(DateSerial(année, mois + 1, 0)) 'nombre de jour dans le mois en parametre
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Worksheets("Feuil1").Activate
    '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
    '"""""""""""""""""""""""""""""""""""""""" Vérifie si mois existe ou pas """"""""""""""""""""""""""""""""""""""""""""
    For Each fc In ActiveWorkbook.Worksheets
        With Worksheets("Paramètre")
            If fc.Name = .Range("C3") & "_" & .Range("B3") Then
                MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "existe déjà", , "Regardez mieux"
                Exit Function
            End If
        End With
    Next fc
    With Worksheets("Feuil1")
        .Cells.Delete
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '""""""""""""""""""""""""""""""""""""""""""""""" Phase lunaire  """"""""""""""""""""""""""""""""""""""""""""""""""""
        lig = 3: col = 3
        Set Cmt = Nothing
        StrComment$ = ""
        lig = 3: col = 3
        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: .Height = 12: End With
                End If
            End With
            col = col + 1
            Set Cmt = Nothing
            StrComment$ = ""
        Next i
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""""""" Base jour """"""""""""""""""""""""""""""""""""""""""""""""""""""""
        lig = 2: col = 3
        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
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""" Fusion Numéro de semaine """""""""""""""""""""""""""""""""""""""""""""""
        i = 1
        While i <= nbjour
            If i = 1 Or Weekday(DateSerial(année, mois, i), vbMonday) = 1 Then
                .Cells(1, 2 + 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, 2 + j), .Cells(1, 2 + i))
                    .Merge
                    .HorizontalAlignment = xlCenter
                End With
            End If
            i = i + 1
        Wend
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""" Heures de travail """"""""""""""""""""""""""""""""""""""""""""""""""""
        HdebAM = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
        lig = 3: lig2 = 4: col = 1
        For i = HdebAM To HfinAM ' Matin
            With .Cells(lig, col)
                .Value = HdebAM
                .Font.Size = 12
                .Font.Bold = True
            End With
            .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
            .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            For j = 1 To (HfinAM - HdebAM)
                .Cells(lig2, 2) = 30
                .Cells(lig2, 2).Font.Size = 9
                .Range(.Cells(lig2, 2), .Cells(lig2 + 1, 2)).MergeCells = True
                .Cells(lig2, 2).VerticalAlignment = xlCenter
                .Cells(lig2, 2).HorizontalAlignment = xlCenter
                .Range(.Cells(lig2, 3), .Cells(lig2, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot
            Next j
            lig = lig + 2: lig2 = lig2 + 2: HdebAM = HdebAM + 1
        Next i
        .Range(.Cells(lig - 1, 1), .Cells(lig + 2, dercol)).Interior.ColorIndex = 24 ' pose
        .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
        With .Cells(lig, 1)
            .Value = "Pose"
            .Font.Bold = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        lig = lig + 2: lig2 = lig + 1
        For i = HdebPM To HfinPM ' Après-midi
            With .Cells(lig, col)
                .Value = HdebPM
                .Font.Size = 12
                .Font.Bold = True
            End With
            .Range(.Cells(lig, 1), .Cells(lig + 1, 1)).MergeCells = True
            .Range(.Cells(lig, 2), .Cells(lig, dercol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Range(.Cells(lig + 1, 1), .Cells(lig + 1, dercol)).Borders(xlEdgeTop).LineStyle = xlContinuous
            For j = 1 To (HfinPM - HdebPM)
                .Cells(lig2, 2) = 30
                .Range(.Cells(lig2, 2), .Cells(lig2 + 1, 2)).MergeCells = True
                .Cells(lig2, 2).VerticalAlignment = xlCenter
                .Cells(lig2, 2).HorizontalAlignment = xlCenter
                .Range(.Cells(lig2, 3), .Cells(lig2, dercol)).Borders(xlEdgeBottom).LineStyle = xlDot
            Next j
            lig = lig + 2: lig2 = lig2 + 2: HdebPM = HdebPM + 1
        Next i
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '""""""""""""""""""""""""""""""""""""""""""" Coloriage des jours """""""""""""""""""""""""""""""""""""""""""""""""""
        HdebAM = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        Ham = (HfinAM - HdebAM) * 2: Hap = (HfinPM - HdebPM) * 2
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
        lig = 2: col = 3
        For i = 1 To nbjour
            'Coloriage ligne n° semaine
            .Cells(lig - 1, col).Interior.ColorIndex = 24
            'Coloriage jours
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            'Coloriage jours chomés
            m = 14
            For l = 1 To 7
                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 + 2, col), .Cells(lig + 1 + Ham, col)).Interior.ColorIndex = 39
                End If
                m = m + 1
            Next l
            .Range(.Cells(lig + 2 + Ham, col), .Cells(derlig - Hap, col)).Interior.ColorIndex = 39
            n = 14
            For s = 1 To 7
                If Worksheets("Paramètre").Range("G" & n).Value = True And Weekday(DateSerial(année, mois, i), vbMonday) = Worksheets("Paramètre").Range("H" & n).Value Then
                    .Range(.Cells(derlig, col), .Cells(derlig + 1 - Hap, col)).Interior.ColorIndex = 39
                End If
                n = n + 1
            Next s
            '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 + 2, col), .Cells(derlig, col)).Interior.ColorIndex = 39
                    With .Range(.Cells(lig + 2 + Ham, col), .Cells(lig + 4 + Ham + 1, col))
                        .MergeCells = True
                        .Font.Size = 12
                        .VerticalAlignment = xlCenter
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With
                    .Cells(lig + 2 + Ham, col) = Jfériéstring(j)
                    With .Cells(lig + 2, col)
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With
                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
                    With .Cells(lig + 2, col)
                        .Value = Jfetestring(k)
                        .HorizontalAlignment = xlCenter
                    End With
                End If
            Next k
            With .Cells(derlig + 3, col)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            col = col + 1
        Next i
        With .Range(.Cells(1, 1), .Cells(derlig, 2))
            .Interior.ColorIndex = 24 'Colonne heures
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        .Range(.Cells(derlig + 1, 1), .Cells(derlig + 2, dercol)).Interior.ColorIndex = 24 'Ligne notes
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '""""""""""""""""""""""""""""""""""""""""""" Quadrillage Agenda """"""""""""""""""""""""""""""""""""""""""""""""""""
        'N°de semaine
        With .Range(.Cells(1, 3), .Cells(1, dercol))
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
        End With
        'Tout les jour du mois
        With .Range(.Cells(2, 3), .Cells(3, dercol))
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
        End With
        With .Range(.Cells(4, 3), .Cells(derlig + 3, dercol))
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
        End With
        With .Range(.Cells(derlig + 3, 1), .Cells(derlig + 3, dercol))
            .Interior.ColorIndex = 35 'Ligne fêtes
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        '"""""""""""""""""""""""""""""""""""""""""""""""" Éphéméride  """"""""""""""""""""""""""""""""""""""""""""""""""""""
        derlig = .Range("A" & Rows.Count).End(xlUp).Row
        .Columns("A").ColumnWidth = 5: .Columns("B").ColumnWidth = 2.15: .Columns("C:AG").ColumnWidth = 20
        col = 3
        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
        derlign = .Range("B" & Rows.Count).End(xlUp).Row
        .Rows(derlig + 2).RowHeight = 80
        .Rows(derlig + 3).RowHeight = 80
        With .Cells(derlig + 2, 1)
            .Value = "Note"
            .Orientation = xlVertical
            .VerticalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
        End With
        With .Cells(derlig + 3, 1)
            .Value = "Fête"
            .Orientation = xlVertical
            .VerticalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
        End With
    End With
    With ActiveWindow: .SplitColumn = 2: .SplitRow = 3: End With: ActiveWindow.FreezePanes = True
    Set WsP = Nothing
    With Worksheets("Paramètre")
        Worksheets("Feuil1").Name = .Range("C3") & "_" & .Range("B3")
        Sheets.Add(Before:=Sheets(1)).Name = "Feuil1"
        Worksheets(.Range("C3") & "_" & .Range("B3")).Activate
        MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "a été créé", , "Bravo !!!!!"
    End With
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 = 3
    With ActiveSheet
        For i = 1 To nbjour
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            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 + 2    '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
Capture d’écran 2024-06-03 125006.jpg


Merci
 

Discussions similaires

Statistiques des forums

Discussions
313 323
Messages
2 097 160
Membres
106 858
dernier inscrit
pedrito7