XL 2021 Création calendrier ( Agenda ) en VBA

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Bonjour à tous,

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

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

Mon (mes) Problème(s)

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

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

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

test form6.gif


Donc si vous pouvez m'aiguiller ou me simplifier le code tout en ayant le même résultat.
Quand j'ai un peu de temps je bricole un peu, donc soyez indulgent sur les critiques.
En vous remerciant d'avance.
Nicolas
 
Dernière édition:
Trier par date Trier par votes
Tu veux avoir un mois (du 1er au dernier jour dudit mois) par feuille ?

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

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

Merci
 
Dernière édition:
Vote positif 0 Vote négatif
Une double proposition (avec, ou sans, fusion de cellules) :
VB: 
Sub Essai()
'
    Call Essai_01(2024, 2)
    Call Essai_02(2024, 2)

End Sub

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

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

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

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

End Sub

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

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

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

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

End Sub
 
Vote positif 0 Vote négatif
TooFatBoy à dit:
Une double proposition (avec, ou sans, fusion de cellules) :
Cliquez pour agrandir...
Bonjour, merci pour ton bout de code, intégré facilement.
merci beaucoup
Nicolas
VB: 
        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
 
Vote positif 0 Vote négatif
Comme tu l'as sûrement remarqué, perso j'évite les lettres accentuées dans les noms de variables, car ça peut poser des problèmes. 😉

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


Tu as maintenant un bel agenda mensuel, taillé sur mesure, au pixel près. 👏
 
Dernière édition:
Vote positif 0 Vote négatif
Voici ou j'en suis pour l'instant.
Si vous avez des améliorations à suggérer, je suis à l'écoute

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

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

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

    Application.DisplayAlerts = False: Application.ScreenUpdating = False

    With Worksheets("Feuil1")

        Cells.Delete

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

            col = col + 1

        Next i

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

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

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

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

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

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

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

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

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

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

End Function


Sub Actualisation()

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

    Actu_jour année, mois

End Sub

Function Actu_jour(année, mois)

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

Public Function PhaseLunaire(dDate As Date) As Integer

    Select Case AgeLune(dDate)

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

Public Function AgeLune(dDate As Date) As Single

    Dim BaseDate As Date

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

End Function

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

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

End Function

test form6.gif


Pour la phase lunaire j'ai intégré un tout pitit bout, je sais pas encore, je veux pas faire une usine à gaz non plus.
Merci
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour le Fil ,
histoire de participer Lol
ce que j'ai modifié:
Code: 
 Dim Cmt As Comment
    Dim StrComment$
    Set Cmt = Nothing
    StrComment$ = ""
    lig = 3: Col = 2
    For I = 1 To Nbjour
        With Cells(lig, Col)
            .Value = PhaseLunaire(DateSerial(année, mois, I))
            Select Case .Value
                Case 1
                    StrComment = "Nouvel lune"
                Case 2
                    StrComment$ = "1er quart de lune"
                Case 3
                    StrComment$ = "Pleine lune"
                Case 4
                    StrComment$ = "Dernier quart de lune"
            End Select
            Set Cmt = .AddComment
            Cmt.Text Text:=StrComment

        End With
        Col = Col + 1
    Next I
Bonne Journée
Jean marie
 
Vote positif 0 Vote négatif
Re
ce que j'ai modifié :
VB: 
   '""""""""""""""""""""""""""""""""""""""""""""""" Phase lunaire  """"""""""""""""""""""""""""""""""""""""""""""""""""

        lig = 3: col = 2
    Dim Cmt As Comment
    Dim StrComment$
    Set Cmt = Nothing
    StrComment$ = ""
    lig = 3: col = 2
    For i = 1 To nbjour
        With Cells(lig, col)
            .Value = PhaseLunaire(DateSerial(année, mois, i))
          
            Select Case .Value
                Case 1
                    StrComment = "Nouvel lune"
                Case 2
                    StrComment$ = "1er quart de lune"
                Case 3
                    StrComment$ = "Pleine lune"
                Case 4
                    StrComment$ = "Dernier quart de lune"
            End Select
            If StrComment <> "" Then
                  Set Cmt = .AddComment
                        Cmt.Text Text:=StrComment
                        With Cmt.Shape
                             .Width = 100   ' Largeur en points
                             .Height = 12 ' Hauteur en points
                        End With
            End If
        End With
        col = col + 1
                             Set Cmt = Nothing
                    StrComment$ = ""
    Next i
Jean marie
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Nicolas JACQUIN
  • Question Question
XL 2021 Vacances scolaires sur calendrier
Réponses
2
Affichages
323
goube
goube
B
  • Question Question
XL 2019 sauvegarde de donnée dans un calendrier automatique
Réponses
5
Affichages
114
fanfan38
fanfan38
O
  • Question Question
XL 2016 Identification et mise en forme des jours fériés dans un calendrier
Réponses
7
Affichages
229
TooFatBoy
TooFatBoy
Nicolas JACQUIN
  • Question Question
XL 2021 Récupérer info météo
8 9 10
Réponses
137
Affichages
4 K
jurassic pork
jurassic pork
C
  • Question Question
XL 2016 Calendrier automatique
2
Réponses
17
Affichages
619
Coqsix
C
Nicolas JACQUIN
  • Résolu(e)
XL 2021 Calendrier Éphéméride Lunaison
3 4 5
Réponses
61
Affichages
2 K
Nicolas JACQUIN
Nicolas JACQUIN
P
  • Question Question
XL 2013 Calendrier
Réponses
8
Affichages
453
AR MOR
A
C
  • Question Question
Microsoft 365 Avoir un calendrier d'équipe du type Outlook, mais sur Excel pour bénéficier des champs de listes
Réponses
1
Affichages
456
ChTi160
ChTi160
F
  • Question Question
Microsoft 365 Excel Calendrier dynamique sur plusieurs années
Réponses
11
Affichages
706
Fanny754
F
L
  • Résolu(e)
XL 2021 Agenda récurrence excel
2
Réponses
27
Affichages
2 K
leoooooooooooooooooo
L
chinel
  • Résolu(e)
XL 2016 problème avec une formule dans excel
Réponses
6
Affichages
307
chinel
chinel
M
  • Question Question
XL 2021 macro VBA
Réponses
4
Affichages
143
ManuEven
M
C
  • Résolu(e)
XL 2016 Mettre en application INDEX et SOMMEPROD en BVA
2 3 4
Réponses
59
Affichages
1 K
candido57
C
V
  • Question Question
Autres Pseudo Calendrier
Réponses
0
Affichages
415
VIARD
V
B
  • Résolu(e)
XL 2021 Calendrier @patricktoulon
Réponses
5
Affichages
637
patricktoulon
patricktoulon
reska
  • Question Question
XL 2021 création d'onglets en masse depuis un modele
Réponses
6
Affichages
81
Phil69970
Phil69970
J
  • Résolu(e)
XL 2019 Création étiquettes en vba
Réponses
12
Affichages
161
job75
job75
S
  • Résolu(e)
Microsoft 365 Vba, Mise en forme d'un calendrier
Réponses
8
Affichages
578
SOP
S
Etoto
  • Résolu(e)
Microsoft 365 VBA Insertion du numéro de semaine de manière dynamique
Réponses
11
Affichages
266
Etoto
Etoto
M
  • Résolu(e)
Microsoft 365 Planning et calendrier vacances
Réponses
8
Affichages
729
MLIZIN
M
Retour