Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook

Nicolas JACQUIN

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

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

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

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

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

    Application.DisplayAlerts = False: Application.ScreenUpdating = False

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

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

    With Worksheets("Feuil1")

        .Cells.Delete

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

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

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

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

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

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

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

        HdebAM = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column

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

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

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

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

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

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

        HdebAM = WsP.Range("C7").Value: HfinAM = WsP.Range("C8").Value
        HdebPM = WsP.Range("C9").Value: HfinPM = WsP.Range("C10").Value
        Ham = (HfinAM - HdebAM) * 2: Hap = (HfinPM - HdebPM) * 2
        derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
        lig = 2: col = 2
        For i = 1 To nbjour

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

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

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

            'Coloriage férié
            For j = 0 To UBound(Jférié)
                If CDate(Jférié(j) & année) = DateSerial(année, mois, i) Then
                    .Range(.Cells(lig + 2, col), .Cells(derlig, col)).Interior.ColorIndex = 39

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

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

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

                End If
            Next j

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

            'Coloriage fête
            For k = 0 To UBound(Jfete)
                If CDate(Jfete(k) & année) = DateSerial(année, mois, i) Then

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

                End If
            Next k

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

            col = col + 1

        Next i

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    End With

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

    With Worksheets("Paramètre")
        Worksheets("Feuil1").Name = .Range("C3") & "_" & .Range("B3")
        Sheets.Add(Before:=Sheets(1)).Name = "Feuil1"
        .Activate
        MsgBox "L'agenda" & " " & .Range("C3") & "_" & .Range("B3") & " " & "a été créé", , "Bravo !!!!!"
    End With
   
End Function


Sub Actualisation()

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

    Actu_jour année, mois

End Sub

Function Actu_jour(année, mois)

    Application.ScreenUpdating = False
    Dim i As Long, nbjour As Long

    nbjour = Day(DateSerial(année, mois + 1, 0)) ' te donne le nombre de jour dans le mois en parametre

    lig = 2: col = 2
    With Worksheets("Feuil1")
        For i = 1 To nbjour
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            If année = year(Date) And mois = Month(Date) And i = Day(Date) Then
                .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 28 'Coloriage aujourd'hui
                ActiveWindow.ScrollColumn = i + 1     'va à la colonne aujourd'hui
            End If
            col = col + 1
        Next i
    End With

End Function

Public Function PhaseLunaire(dDate As Date) As Integer
    Select Case AgeLune(dDate)
        Case Is > Synod - 1 'Nouvelle lune
            PhaseLunaire = 1
        Case Synod / 4 - 1 To Synod / 4 '1/4 de lune
            PhaseLunaire = 2
        Case Synod / 2 - 1 To Synod / 2 'Pleine lune
            PhaseLunaire = 3
        Case 3 * Synod / 4 - 1 To 3 * Synod / 4 '3/4 de lune
            PhaseLunaire = 4
        Case Else 'Lune noir
            PhaseLunaire = 0
    End Select
End Function

Public Function AgeLune(dDate As Date) As Single
    Dim BaseDate As Date
    BaseDate = CDate(BaseNewMoonDateString)
    AgeLune = REMAINDER((dDate - BaseDate), Synod)
End Function

Public Function REMAINDER(Number As Variant, DivideBy As _
                          Variant) As Variant
    If Number = 0 Then REMAINDER = 0 Else REMAINDER = Number - DivideBy * Int(Number / DivideBy)
End Function

 

Pièces jointes

  • Agenda v22.xlsm
    86.3 KB · Affichages: 7
Dernière édition:
Trier par date Trier par votes

TooFatBoy

XLDnaute Barbatruc
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.
 
Vote positif 0 Vote négatif

TooFatBoy

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


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

Gégé-45550

XLDnaute Accro
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,
 
Vote positif 0 Vote négatif

Gégé-45550

XLDnaute Accro
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 ?
 
Vote positif 0 Vote négatif

Nicolas JACQUIN

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

VB: 
Sub Actualisation()

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

    Actu_jour année, mois

End Sub

Function Actu_jour(année, mois)

    Application.ScreenUpdating = False
    Dim i As Long, nbjour As Long

    nbjour = Day(DateSerial(année, mois + 1, 0)) ' te donne le nombre de jour dans le mois en parametre

    lig = 2: col = 2
    With Worksheets("Feuil1")
        For i = 1 To nbjour
            .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 24
            If année = year(Date) And mois = Month(Date) And i = Day(Date) Then
                .Range(.Cells(lig, col), .Cells(lig + 1, col)).Interior.ColorIndex = 28 'Coloriage aujourd'hui
                ActiveWindow.ScrollColumn = i + 1     'va à la colonne aujourd'hui
            End If
            col = col + 1
        Next i
    End With

End Function
 
Vote positif 0 Vote négatif

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
C'est à retravailler sans doute, mais dans ce contexte
 
Vote positif 0 Vote négatif

Nicolas JACQUIN

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

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

Sub Actualisation()
    année = year(Date)
    mois = Month(Date)
    Actu_jour année, mois
End Sub

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

Public Function PhaseLunaire(dDate As Date) As Integer
    Select Case AgeLune(dDate)
        Case Is > Synod - 1 'Nouvelle lune
            PhaseLunaire = 1
        Case Synod / 4 - 1 To Synod / 4 '1/4 de lune
            PhaseLunaire = 2
        Case Synod / 2 - 1 To Synod / 2 'Pleine lune
            PhaseLunaire = 3
        Case 3 * Synod / 4 - 1 To 3 * Synod / 4 '3/4 de lune
            PhaseLunaire = 4
        Case Else 'Lune noir
            PhaseLunaire = 0
    End Select
End Function

Public Function AgeLune(dDate As Date) As Single
    Dim BaseDate As Date
    BaseDate = CDate(BaseNewMoonDateString)
    AgeLune = REMAINDER((dDate - BaseDate), Synod)
End Function

Public Function REMAINDER(Number As Variant, DivideBy As _
                          Variant) As Variant
    If Number = 0 Then REMAINDER = 0 Else REMAINDER = Number - DivideBy * Int(Number / DivideBy)
End Function


Merci
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
XL 2019 Fusionner jusqu'à dernière colonne contenant
Réponses
8
Affichages
529
TooFatBoy
M
  • Question
Microsoft 365 Modifier code et format textbox
2 3
Réponses
35
Affichages
1 K
Marvin57
M
  • Question
XL 2016 Protéger Plage avec condition
2
Réponses
16
Affichages
750
Amigo
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
398
AtTheOne
D
  • Question
Microsoft 365 Dupliquer des lignes dans une autre feuille avec une condition
2
Réponses
26
Affichages
2 K
de_hanstrapp
D
  • Résolu(e)
XL 2010 Module de classe avec Dictionary
3 4 5
Réponses
66
Affichages
2 K
patricktoulon
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
150
vgendron
  • Question
Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.
Réponses
3
Affichages
720
ARMAEL
A
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
373
vgendron
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
860
Phil69970
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…