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 · 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...

Nicolas JACQUIN · 26 Août 2024

Ca doit être tout bête dans le "Worksheet_SelectionChange" mais je sèche je crois

Nicolas JACQUIN · 26 Août 2024

Quelqu'un aurait une idée pour me débloquer dès fois
merci

jcf6464 · 26 Août 2024

Bonsoir Nicolas et le forum,

"Worksheet_SelectionChange"

Cela ne viens pas de là

Tu rajoute un caractère à la cellule c'est cela qui bloque,

je ne suis pas expert mais j'ai supprimé les caractères et cela fonctionne, je pense que tu les rajoutent à la main !!!

bonne continuation jcf

Nicolas JACQUIN · 26 Août 2024

jcf6464 à dit:
Bonsoir Nicolas et le forum,

Cela ne viens pas de là

Tu rajoute un caractère à la cellule c'est cela qui bloque,

je ne suis pas expert mais j'ai supprimé les caractères et cela fonctionne, je pense que tu les rajoutent à la main !!!

bonne continuation jcf

Bonsoir jcf6464,

si ça viens de là, je rajoute le caractère dans cette fonction

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

Et du coup mon jour du calendrier me renvoie une erreur vue qu'il y a un caractère en plus qui n'a rien à voir avec le jour.
Mais j'arrive pas à trouver la parade, ça doit pas être compliqué pourtant mais je suis pas un as

jcf6464 · 26 Août 2024

re

Mais j'arrive pas à trouver la parade, ça doit pas être compliqué pourtant mais je suis pas un as

Moi non plus

Bonne continuation,

Nicolas JACQUIN · 26 Août 2024

C'est à la sélection du jour, vu que j'ai rajouter des caractères sur les jours ou la phase change il ne sont plus reconnus

Pour ça j'essai plusieurs chose mais sans succès

Nicolas JACQUIN · 26 Août 2024

Voici le code qui me pose problème et qui me donne l'erreur du message précédent.

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim i
    Dim Interval
    Dim Texte
    Dim HZenith As String
    Dim EnsolPréc As Date
    Dim EnsolJour As Date
    Dim cell As Range
    Dim contientChiffre As Boolean

    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("Calendrier")) Is Nothing Then Exit Sub

    Set cell = Target
    'If IsNumeric(Target) Then

    ' Parcourir chaque caractère dans la cellule
    For k = 1 To Len(cell.Value)
        ' Vérifier si le caractère est un chiffre
        If IsNumeric(Mid(cell.Value, k, 1)) Then
            contientChiffre = True


            With Forme

                .Lbl_CoefAM1 = "": .Lbl_BMAM1 = "": .Lbl_HMAM1 = "": .Lbl_CoefPM1 = "": .Lbl_BMPM1 = "": .Lbl_HMPM1 = ""
                .Lbl_CoefAM2 = "": .Lbl_BMAM2 = "": .Lbl_HMAM2 = "": .Lbl_CoefPM2 = "": .Lbl_BMPM2 = "": .Lbl_HMPM2 = ""
                .Lbl_CoefAM3 = "": .Lbl_BMAM3 = "": .Lbl_HMAM3 = "": .Lbl_CoefPM3 = "": .Lbl_BMPM3 = "": .Lbl_HMPM3 = ""

                .Lbl_MaréeJour = "": .Lbl_MaréeJour.ForeColor = -2147483630

                a = year(Range("B1")): M = month(Range("B1")): j = cell.Value
                vdate = DateSerial(a, M, j) 'endroit de l'erreur

                fete (vdate)
                Mareee (vdate)

                With Sheets("Lune").ListObjects("t_Lune")
                    For i = 1 To .ListRows.Count
                        Interval = DateDiff("d", vdate, .DataBodyRange(i, 2))
                        Debug.Print Interval
                        If Interval > 1 Then
                            Texte = Hour(.DataBodyRange(i, 3)) & " h " & Minute(.DataBodyRange(i, 3)) & " min " & "dans " & Interval & " jours"
                            Forme.Label86.Caption = "( par rapport à la date sélectée )"
                        ElseIf Interval = 1 Then
                            Texte = Hour(.DataBodyRange(i, 3)) & " h " & Minute(.DataBodyRange(i, 3)) & " min " & "demain"
                            Forme.Label86.Caption = "( par rapport à la date sélectée )"
                        ElseIf Interval = 0 Then
                            Texte = Hour(.DataBodyRange(i, 3)) & " h " & Minute(.DataBodyRange(i, 3)) & " min "
                            Forme.Label86.Caption = "( par rapport à la date sélectée )"
                        End If

                        If Interval >= 0 Then
                            Select Case Asc(.DataBodyRange(i, 1))
                                Case 153
                                    'Range("D17") = "Pleine Lune à " & Texte
                                    Forme.Lbl_NextLune = "Pleine Lune à " & Texte
                                   
                                Case 130
                                    'Range("D17") = "Premier Quartier à " & Texte
                                    Forme.Lbl_NextLune = "Premier Quartier à " & Texte
                                   
                                Case 152
                                    'Range("D17") = "Nouvelle Lune à " & Texte
                                    Forme.Lbl_NextLune = "Nouvelle Lune à " & Texte
                                   
                                Case 131
                                    'Range("D17") = "Dernier Quartier à " & Texte
                                    Forme.Lbl_NextLune = "Dernier Quartier à " & Texte
                                   
                            End Select
                            Exit For
                        End If
                    Next i
                    ''''''''''''''''''''''''''''''''''''''''''''''''''''
                End With

                '.Lbl_Jour.Caption = IIf(vdate = Date, WorksheetFunction.Proper(Format(vdate, "dddd")) & " " & Format(vdate, "dd mmmm yyyy") & " " & _
                                                                                               '"(aujourd'hui)", WorksheetFunction.Proper(Format(vdate, "dddd")) & " " & Format(vdate, "dd mmmm yyyy"))
                .Lbl_Jour.Caption = WorksheetFunction.Proper(Format(vdate, "dddd")) & " " & Format(vdate, "dd mmmm yyyy")

                .Lbl_NumSem.Caption = "Semaine n° " & DatePart("ww", vdate, vbMonday, vbFirstFourDays)
                .Lbl_PosJour.Caption = DatePart("y", vdate) & " ème jour de l'année."

                DateDebut = vdate: DateFin = CDate("31/12/" & (a))
                NbJours = DateDiff("d", DateDebut, DateFin)
                .Lbl_NbJourRestant.Caption = NbJours & " jours restant."

                .Lbl_NvlLune.Caption = Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(1, 2)
                .Lbl_PreQu.Caption = Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(2, 2)
                .Lbl_PleineLune.Caption = Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(3, 2)
                .Lbl_DernierQuartier.Caption = Worksheets("Lune").ListObjects("t_Lune").DataBodyRange(4, 2)

                ExtraireLevercoucherDuSoleil (vdate - 1)
                EnsolPréc = Ensoleil
                ExtraireLevercoucherDuSoleil (vdate)
                EnsolJour = Ensoleil

                'Forme.Lbl_LeverSoleil = "Lever du soleil" & vbTab & vbTab & LeverTU
                Forme.Lbl_LeverSoleil = "Lever du soleil" & vbTab & vbTab & Format(LeverTU, "hh:mm")

                'Forme.Lbl_CoucherSoleil = "Coucher du soleil" & vbTab & CoucherTU
                Forme.Lbl_CoucherSoleil = "Coucher du soleil" & vbTab & Format(CoucherTU, "hh:mm")

                'Forme.Lbl_Ensoleillement = "Ensoleillement " & vbTab & vbTab & EnsolJour
                Forme.Lbl_Ensoleillement = "Ensoleillement" & vbTab & vbTab & Format(EnsolJour, "hh:mm")

                Forme.dif_ensoleil = "(" & IIf(EnsolPréc > EnsolJour, "-", "+") & Format(Minute(EnsolPréc - EnsolJour), "0") & " min)"

                HZenith = Format(ZenithTime(vdate, 3.36667), "hh:mm:ss")
                'Forme.Lbl_Zenith = "Zenith " & vbTab & vbTab & vbTab & HZenith
                Forme.Lbl_Zenith = "Zenith" & vbTab & vbTab & vbTab & Format(HZenith, "hh:mm")

                Call JoursRestantsAvantProchaineSaison

            End With
        End If
    Next k
End Sub

Si quelqu'un veux bien m'éclairer

Nicolas JACQUIN · 26 Août 2024

J'ai trouvé la parade

Yessssssss

Nicolas JACQUIN · 26 Août 2024

Pour l'instant c'est bon, le seul truc, si quelqu'un sait comment avoir les phases sur n'importe quels mois et année ? Selon la sélection

Nicolas JACQUIN · 26 Août 2024

jcf6464 à dit:
Cela ne viens pas de là

Dans "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"

VB:

j = Left(Target, 2)

Et dans le module "Mod_Saison" pareillement

goube · 27 Août 2024

Nicolas JACQUIN à dit:
Nicolas JACQUIN à dit:

Pour l'instant c'est bon, le seul truc, si quelqu'un sait comment avoir les phases sur n'importe quels mois et année ? Selon la sélection

Cliquez pour agrandir...

Sur le fichier déposé, le lien donne l'année en cours et l'année à venir.
Cordialement

jcf6464 · 27 Août 2024

Bonjour à vous tous

Sur le module Mod_saison une erreur voir

Passe le classeur du post 23 merci
Bonne continuation

Nicolas JACQUIN · 27 Août 2024

Bonjour tous le monde,

A jcf6464, J'ai pas d'erreur,

Nicolas JACQUIN · 27 Août 2024

oups, oui j'avais mis

VB:

j = Left(ActiveCell.Value, 2)

Nicolas JACQUIN · 27 Août 2024

ou

VB:

j = Left(ActiveCell, 2)

XL 2021 Calendrier Éphéméride Lunaison

Nicolas JACQUIN

XLDnaute Impliqué

Pièces jointes

Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

jcf6464

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

jcf6464

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

goube

XLDnaute Impliqué

jcf6464

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Pièces jointes

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Discussions similaires