XL 2021 Calendrier Éphéméride Lunaison

Nicolas JACQUIN · 24 Août 2024

Bonjour à tous,

Je termine mon calendrier mais bug sur un point encore,
Sur la partie lunaison
j'essai de trouver une solution pour que à la création du calendrier, j'ai juste un commentaire qui se crée sur le jour ou il y a un changement de phase lunaire (éventuellement avec l'heure, qui sont déjà accessible).

Certains d'entre vous mon déjà beaucoup aidé et connaisse le fichier.

Merci à tous
Nico

Nicolas JACQUIN · 24 Août 2024

Sur mon ancienne version j'avais réussi mais vu que la fonction lunaison
n'à plus rien à voir je suis perdu.

Un petit aperçu pour donner l'idée.

sousou · 24 Août 2024

Bonjour
regarde ceci, lors du calcul de la lunaison, je vais inscrire les changement de phase.
A fignoler pour le rendu souhaité

Nicolas JACQUIN · 24 Août 2024

sousou à dit:
Bonjour
regarde ceci, lors du calcul de la lunaison, je vais inscrire les changement de phase.
A fignoler pour le rendu souhaité

Bonjour sousou,

Merci, c'est quasiment le résultat souhaité, si il y a moyen d'avoir la phase, 1er quart, pleine lune, nouvelle lune, dernier quart,
se serait le top.

Nico

Modeste geedee · 25 Août 2024

Bonsour
L'age de la lunaison s'obtient très facilement :
A partir du calendrier Hegirien il s'agit du n° du jour
(à 12 heures près)
=UneDate
Format de cellule :
"B1j"

goube · 25 Août 2024

Bonsoir à tous,

Si cela peut aider, une archive des phases lunaires.
Cordialement

Nicolas JACQUIN · 25 Août 2024

Bonjour à tous,

Merci à goube, je vais regarder ça.

Sinon après quelque modifs visuels juste, je rejoinds le fichier si quelqu'un à des idées.

Merci à tous

Nicolas JACQUIN · 25 Août 2024

Re bonjour tous le monde,

J'ai plus ou moins trouvé la réponse à ma question, le commentaire se rajoute bien avec la phase
sur le jour souhaité, mais, oui y a un mais 🙂 🙂 , l'heure de la phase ne correspond pas et je sais pas ou j'ai fait l'erreur.

VB:

Sub recup_phase()
    recup = recup_phase_lune(year(Range("B1")), month(Range("B1")))
End Sub

Function recup_phase_lune(année, mois)
    Dim i As Long, col As Long, lig As Long, nbjour As Long

    Application.ScreenUpdating = False

    nbjour = day(DateSerial(année, mois + 1, 0))    ' te donne le nombre de jours dans le mois en parametre
    col = Weekday(DateSerial(année, mois, 1), vbMonday) + 1 ' te donne l'index du jour de la semaine (commencant un lundi), et ajouter 1 si calendrier commence en colonne "A"
    lig = 3

    With Worksheets("Calendrier")
   
        For i = 1 To nbjour

            If col = 9 Then lig = lig + 2: col = 2 'pour changer de ligne quand on arrive au dimanche

                If Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 2) = DateSerial(année, mois, i) Then 'si on est sur la date du jour
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Nouvelle lune" & " à " & Hour(Worksheets("Lune").ListObjects("t_Lune") _
                    .DataBodyRange(i, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 3)) & " min "
                   
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Premier quartier de lune" & Texte & " à " & Hour(Worksheets("Lune") _
                    .ListObjects("t_Lune").DataBodyRange(i, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 3)) & " min "
                   
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Pleine lune" & " à " & Hour(Worksheets("Lune").ListObjects("t_Lune"). _
                    DataBodyRange(i, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 3)) & " min "
                   
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Dernier quartier de lune" & " à " & Hour(Worksheets("Lune"). _
                    ListObjects("t_Lune").DataBodyRange(i, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 3)) & " min "
                   
                End If

            col = col + 1 'on se déplace sur le jour suivant

        Next i
       
    End With

    Application.ScreenUpdating = True
End Function

Merci
Nico

sousou · 25 Août 2024

Nicolas JACQUIN à dit:
Bonjour sousou,

Merci, c'est quasiment le résultat souhaité, si il y a moyen d'avoir la phase, 1er quart, pleine lune, nouvelle lune, dernier quart,
se serait le top.

Nico

Bonjour
Avec les phases😉

Nicolas JACQUIN · 25 Août 2024

En me relisant j'ai vu mon erreur 🙁 🙁

VB:

Sub recup_phase()
    recup = recup_phase_lune(year(Range("B1")), month(Range("B1")))
End Sub

Function recup_phase_lune(année, mois)
    Dim i As Long, col As Long, lig As Long, nbjour As Long

    Application.ScreenUpdating = False

    nbjour = day(DateSerial(année, mois + 1, 0))    ' te donne le nombre de jours dans le mois en parametre
    col = Weekday(DateSerial(année, mois, 1), vbMonday) + 1 ' te donne l'index du jour de la semaine (commencant un lundi), et ajouter 1 si calendrier commence en colonne "A"
    lig = 3

    With Worksheets("Calendrier")
    
        For i = 1 To nbjour

            If col = 9 Then lig = lig + 2: col = 2 'pour changer de ligne quand on arrive au dimanche
            
                If Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 2) = DateSerial(année, mois, i) Then 'si on est sur la date du jour
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Nouvelle lune" & " à " & Hour(Worksheets("Lune").ListObjects("t_Lune") _
                    .DataBodyRange(1, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 3)) & " min "
                    
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Premier quartier de lune" & Texte & " à " & Hour(Worksheets("Lune") _
                    .ListObjects("t_Lune").DataBodyRange(2, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 3)) & " min "
                    
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Pleine lune" & " à " & Hour(Worksheets("Lune").ListObjects("t_Lune"). _
                    DataBodyRange(3, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 3)) & " min "
                    
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Dernier quartier de lune" & " à " & Hour(Worksheets("Lune"). _
                    ListObjects("t_Lune").DataBodyRange(4, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 3)) & " min "
                    
                End If

            col = col + 1 'on se déplace sur le jour suivant

        Next i
        
    End With

    Application.ScreenUpdating = True
End Function

Nicolas JACQUIN · 25 Août 2024

Nicolas JACQUIN · 25 Août 2024

sousou à dit:
Bonjour
Avec les phases😉

Merci du retour, j'ai trouvé une parade.
Tu as un bug au 12/08 je sais pas ce qui c'est passé

Merci

jcf6464 · 26 Août 2024

Bonjour à tous et le forum,

Je vous suis depuis un certain temps beau travail,

Pour le bug de la date du 12 Aout en changeant de mois puis revenir sur le mois précédent la date s'affiche

si cela peut vous éclaircir la vision du code

bonne continuation jcf 👍

sousou · 26 Août 2024

J'avais effacé le 12 par erreur

Nicolas JACQUIN · 26 Août 2024

Bonjour l'ami et le forum,
Décidément on se lis dans les pensées, j'allais poster une modif encore, mais j'ai un trou.
Mon code précédent je l'ai mi dans Mod_Calendrier, je l'ai modifié, ce qui donne ça à la création du calendrier du mois, mais quand je clic sur les jours de changement de phase il se passe rien, donc à réfléchir encore pour moi. Je sais pourquoi mais il faut que je trouve encore la parade. 🙂 🙂 😉 😉

VB:

Function recup_phase_lune(année, mois)
    Dim i As Long, col As Long, lig As Long, nbjour As Long
    Dim dernierIndice As Integer
    Dim texte

    Application.ScreenUpdating = False

    nbjour = day(DateSerial(année, mois + 1, 0))    ' te donne le nombre de jours dans le mois en parametre
    col = Weekday(DateSerial(année, mois, 1), vbMonday) + 1 ' te donne l'index du jour de la semaine (commencant un lundi), et ajouter 1 si calendrier commence en colonne "A"
    lig = 3

    With Worksheets("Calendrier")
   
        For i = 1 To nbjour

            If col = 9 Then lig = lig + 2: col = 2 'pour changer de ligne quand on arrive au dimanche
           
                If Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 2) = DateSerial(année, mois, i) Then 'si on est sur la date du jour
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Nouvelle lune" & vbCrLf & "à " & vbCrLf & Hour(Worksheets("Lune").ListObjects("t_Lune") _
                    .DataBodyRange(1, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 3)) & " min "
                   
                    .Cells(lig, col) = .Cells(lig, col) & " " & Chr(152)
                    dernierIndice = Len(.Cells(lig, col))
                    .Cells(lig, col).Characters(dernierIndice - 1, 2).Font.Name = "Wingdings 2"
                   
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Premier quartier de lune" & vbCrLf & "à " & vbCrLf & Hour(Worksheets("Lune") _
                    .ListObjects("t_Lune").DataBodyRange(2, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 3)) & " min "
                   
                    .Cells(lig, col) = .Cells(lig, col) & " " & Chr(130)
                    dernierIndice = Len(.Cells(lig, col))
                    .Cells(lig, col).Characters(dernierIndice - 1, 2).Font.Name = "Wingdings 2"
                   
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Pleine lune" & vbCrLf & "à " & vbCrLf & Hour(Worksheets("Lune").ListObjects("t_Lune"). _
                    DataBodyRange(3, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 3)) & " min "
                   
                    .Cells(lig, col) = .Cells(lig, col) & " " & Chr(153)
                    dernierIndice = Len(.Cells(lig, col))
                    .Cells(lig, col).Characters(dernierIndice - 1, 2).Font.Name = "Wingdings 2"
                   
                ElseIf Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 2) = DateSerial(année, mois, i) Then
                    .Cells(lig, col).AddComment
                    .Cells(lig, col).Comment.Text Text:="Dernier quartier de lune" & vbCrLf & "à " & vbCrLf & Hour(Worksheets("Lune"). _
                    ListObjects("t_Lune").DataBodyRange(4, 3)) & " h " & Minute(Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 3)) & " min "
                   
                    .Cells(lig, col) = .Cells(lig, col) & " " & Chr(131)
                    dernierIndice = Len(.Cells(lig, col))
                    .Cells(lig, col).Characters(dernierIndice - 1, 2).Font.Name = "Wingdings 2"
                   
                End If

            col = col + 1 'on se déplace sur le jour suivant

        Next i
       
    End With

    Application.ScreenUpdating = True
End Function

XL 2021 Calendrier Éphéméride Lunaison

XLDnaute Accro

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

Pièces jointes

XLDnaute Accro

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Accro

XLDnaute Accro

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Accro

Pièces jointes

Discussions similaires

Nous accordons de l'importance à votre vie privée