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

patricktoulon · 8 Juin 2024

Bonjour juste en passant
tu parles d'exporter la feuille agenda créée ok
tu parles d'exporter le thisworkbook aussi ok
mais c'est absurde car dans le open tu appelle la sub actualisation qui elle même appelle une autre
donc au final il faudrait que tu exporte ta feuille agenda créée + le thisworkbook +le module agenda

moi je me dit que t'a pas compris un truc là

d'autre part une fois ta feuille créée dis moi a quoi servirait ton module dans le nouveau fichier

Nicolas JACQUIN · 8 Juin 2024

Bonjour Patrick,
le but est d'exporter un agenda créé ( celui du mois courant ), le but d'exporter le thisworkbook c'est de permettre quand j'ouvre l'agenda courant la date s'actualise et scrool sur le jour qu'on est ( comme ça fait quand je le crée déjà ).
Merci

Nicolas JACQUIN · 8 Juin 2024

Voici ou en est le code

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
    Actualisation
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 = (dDate - BaseDate) Mod Synod
End Function

Code:

Private Sub Workbook_Open()
    Actualisation

    With Worksheets("Paramètre")
        .Activate
    End With

    ActiveWindow.ScrollColumn = 1

End Sub

Merci

Nicolas JACQUIN · 8 Juin 2024

patricktoulon à dit:
donc au final il faudrait que tu exporte ta feuille agenda créée + le thisworkbook +le module agenda

moi je me dit que t'a pas compris un truc là

Re si j'ai compris, je sais qu'il faut que je mettes le module "Actualisation" complet, sinon ça fonctionnera pas c'est sûre.

patricktoulon · 8 Juin 2024

re
j'avais très bien compris l'intention
mais c'est absurde ta demande
comment veux tu actualiser dans le nouveau classeur si tu n'a pas la sub actualisation et les autres qui y sont associées
réfléchi une seconde

il te faut donc exporter:
ta feuille (ici pour l'exemple "Mai")
le module thisworkbook(ou écrire le open dynamiquement dans le open du nouveau classeur )
le module avec les fonctions actualisation actu_jour , etc......
il y a un énorme vide conceptuel ton truc
alors au mieux
je séparerais les subs et fonctions associées aux feuilles créées du reste du code de création dans un autre module afin de pouvoir l'exporter le cas échéant
donc conclusion l'exportation est une méthode ici inutile car un simple saveAS sauverait ton nouveau classeur pour "Mai" une réouverture afin de supprimer la feuille création et son module de fonction
te resterai alors la feuille "Mai" avec son module de fonction actu et tout y cointi
bref
je dirais même mieux
la création du mois de mai devrait se faire directement dans un new classeur
et j’écrirais directement dans le module thisworkbook dans le open la ligne de code pour le scroll
terminé

Nicolas JACQUIN · 8 Juin 2024

On c'est croisé, oui il faut la fonction avec c'est sûre comme je disais sinon ça peut pas fonctionner, c'est sans doute mieux de mettre dans un deuxième module oui aussi

Nicolas JACQUIN · 8 Juin 2024

patricktoulon à dit:
la création du mois de mai devrait se faire directement dans un new classeur
et j’écrirais directement dans le module thisworkbook dans le open la ligne de code pour le scroll
terminé

Oui aussi, sans doute plus simple

Effectuez une recherche sur Excel Downloads...

XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook

Nicolas JACQUIN

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums