XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook

Nicolas JACQUIN · 2 Juin 2024

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

TooFatBoy · 2 Juin 2024

Bonjour,

J'ai seulement regardé une fonction dans le code que tu as posté, et je me demande, mais peut-être me trompé-je, si ce "REMAINDER" ne ressemble pas fortement à un modulo.

Nicolas JACQUIN · 2 Juin 2024

TooFatBoy à dit:
si ce "REMAINDER" ne ressemble pas fortement à un modulo.

Bonjour TooFatBoy, escuses-moi j'ai pas compris ce que tu veux dire

TooFatBoy · 2 Juin 2024

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 · 2 Juin 2024

Nicolas JACQUIN à dit:

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,

Nicolas JACQUIN · 2 Juin 2024

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

Gégé-45550 · 2 Juin 2024

Nicolas JACQUIN à dit:
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 · 2 Juin 2024

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 · 2 Juin 2024

Nicolas JACQUIN à dit:

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

TooFatBoy · 2 Juin 2024

Nicolas JACQUIN à dit:
excuse-moi je n'ai pas compris ce que tu veux dire.

Je t'ai répondu en #4.

Nicolas JACQUIN · 2 Juin 2024

TooFatBoy à dit:
Je t'ai répondu en #4.

je l'avais fait comme ça à l'époque, c'est qu'un échantillon d'un très gros code récupéré

TooFatBoy · 2 Juin 2024

Nicolas JACQUIN à dit:
je l'avais fait comme ça à l'époque, c'est qu'un échantillon d'un très gros code récupéré

Si la fonction correspond bien à un modulo, alors tu peux la supprimer et du coup ton code sera un peu moins gros.

Nicolas JACQUIN · 3 Juin 2024

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

Merci

TooFatBoy · 3 Juin 2024

Gégé-45550 à dit:
Désolé mais ce n'est pas clair !
ThisWorkBook n'est pas un module mais une propriété de l'application Excel.

Je crois que le monsieur dit qu'il veut exporter aussi le code contenu dans ThisWorkbook, et probablement également celui des modules standards.

Nicolas JACQUIN · 5 Juin 2024

Bonsoir à tous, oui pour être plus précis, je souhaiterai pouvoir exporter l'agenda créé ainsi que le contenant de "Private Sub Workbook_Open()"

VB:

Private Sub Workbook_Open()
   "le code"
End Sub

Merci d'avance à tous
Nicolas

Effectuez une recherche sur Excel Downloads...

XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook

Nicolas JACQUIN

XLDnaute Impliqué

Pièces jointes

TooFatBoy

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

Gégé-45550

XLDnaute Accro

Nicolas JACQUIN

XLDnaute Impliqué

Gégé-45550

XLDnaute Accro

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums