XL 2021 Création agenda

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 !

Nicolas JACQUIN

XLDnaute Accro
Supporter XLD
Bonsoir tout le monde,

Sur ma création d'agenda, j'ai un petit problème avec mon code, y a un petit truc que j'arrive pas à régler.
Si le mois n'existe pas je le créer sans soucis, mais si le mois existe, ça me dis que le moi existe déjà, je dis ok mais sur ma feuille paramètre ça scroll jusqu'à la colonne "Q", il y a une tuile, je vois un peut près ou mais j'arrive pas à l'interpétrer comme il faut.

Merci à tous
Nico

test form6.gif


test form7.gif
 

Pièces jointes

Dernière édition:
Solution
Nicolas

Ton Pb vient d'ici

1726522227041.png

et comme je ne pense pas que l'on peut scroller une feuille non active il faudrait mémoriser le nombre de scroll de colonne

VB:
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 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...
Bon, ça fait 6 à 7 message que j'essai de partager un truc trouvé et bidouiller qui serai peut-être pas mal
En module 1

VB:
Sub CalculerAgeDansTableau()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim i As Long
    Dim dateNaissance As Date
    Dim age As Long
    Dim ligne As ListRow

    Set ws = ThisWorkbook.Sheets("Paramètre")

    Set tbl = ws.ListObjects("t_Anniv")

    For Each ligne In tbl.ListRows

        dateNaissance = ligne.Range(1, tbl.ListColumns("Date").Index).Value

        age = DateDiff("yyyy", dateNaissance, Date)

        If Date < DateSerial(Year(Date), Month(dateNaissance), Day(dateNaissance)) Then
            age = age - 1
        End If

        ligne.Range(1, tbl.ListColumns("Âge").Index).Value = age

        If ligne.Range(1, tbl.ListColumns("Date").Index).Value = "" Then
            ligne.Range(1, tbl.ListColumns("Âge").Index).Value = ""
        End If

        If ligne.Range(1, tbl.ListColumns("Inconnu").Index).Value = "x" Then
            ligne.Range(1, tbl.ListColumns("Âge").Index).Value = ""
        End If

    Next ligne

    MsgBox "Calcul des âges terminé !"
End Sub

Capture d’écran 2024-09-23 172523.jpg


Le tout c'est d'adapter
 

Pièces jointes

Comme je disais sur les autre message, les calcul se font pas, si tu as 1 an aujourd'hui, l'année prochaine tu ne peux pas avoir 1 an aussi
OK, je comprends ce que tu veux dire.

C'est normal : les calculs de l'âge sont faux puisqu'ils sont basés sur Date au lieu d'être basés sur l'année du mois en construction. 😉
 
Dernière édition:
VB:
Function annive(Annee, Mois)
'
Dim i As Long, l As Long, lig As Long, nbjours As Long

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    nbjours = Day(DateSerial(Annee, Mois + 1, 0)) ' Nombre de jours dans le mois passé en paramètre

    For Each fc In ActiveWorkbook.Worksheets

        With Worksheets("Paramètre")

            If fc.Name = .Range("C3") & "_" & .Range("B3") Then
                fc.Activate
                derlig = Range("A" & Rows.Count).End(xlUp).Row
                fc.Range("C" & derlig - 1 & ":AG" & derlig) = ""

                For i = 1 To nbjours

                    anniv = ""

                    With Sheets("Paramètre").ListObjects("t_Anniv")

                        For k = 1 To .ListRows.Count
                            If Month(.ListColumns("Date").DataBodyRange(k)) = Mois And Day(.ListColumns("Date").DataBodyRange(k)) = i Then
                                anniv = anniv & .ListColumns("Anniversaire").DataBodyRange(k)
                                If .ListColumns("Inconnu").DataBodyRange(k) = "x" Then
                                    anniv = anniv & "," & vbCrLf
                                Else
                                    If Annee - Year(.ListColumns("Date").DataBodyRange(k)) = 0 Then
                                        age = "(Naissance)"
                                    Else
                                        age = "(" & Annee - Year(.ListColumns("Date").DataBodyRange(k)) & " ans)"
                                    End If
                                    anniv = anniv & " " & age & "," & vbCrLf
                                End If
                            End If
                        Next k

                        If anniv <> "" Then
                            anniv = Left(anniv, Len(anniv) - 3)
                            fc.Cells(derlig - 1, i + 2) = "Anniversaire de :"
                            fc.Cells(derlig, i + 2) = vbCrLf & anniv
                            fc.Cells(derlig, i + 2).VerticalAlignment = xlTop
                        End If

                    End With

                Next i

            End If

        End With

    Next fc
    
'    Worksheets("Paramètre").Activate

End Function
 
Dernière édition:
VB:
Function annive(Annee, Mois)
'
Dim i As Long, l As Long, col As Long, lig As Long, nbjours As Long

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    nbjours = Day(DateSerial(Annee, Mois + 1, 0)) ' Nombre de jours dans le mois passé en paramètre

    For Each fc In ActiveWorkbook.Worksheets
        With Worksheets("Paramètre")
            If fc.Name = .Range("C3") & "_" & .Range("B3") Then
                fc.Activate
                derlig = Range("A" & Rows.Count).End(xlUp).Row
                col = 3
                fc.Range("C" & derlig - 1 & ":AG" & derlig) = ""

                For i = 1 To nbjours

                    anniv = ""

                    With Sheets("Paramètre").ListObjects("t_Anniv")

                        For k = 1 To .ListRows.Count
                            If Month(.ListColumns("Date").DataBodyRange(k)) = Mois And Day(.ListColumns("Date").DataBodyRange(k)) = i Then
                                anniv = anniv & .ListColumns("Anniversaire").DataBodyRange(k)
                                If .ListColumns("Inconnu").DataBodyRange(k) = "x" Then
                                    anniv = anniv & "," & vbCrLf
                                Else
                                    If Annee - Year(.ListColumns("Date").DataBodyRange(k)) = 0 Then
                                        age = "(Naissance)"
                                    Else
                                        age = "(" & Annee - Year(.ListColumns("Date").DataBodyRange(k)) & " ans)"
                                    End If
                                    anniv = anniv & " " & age & "," & vbCrLf
                                End If
                            End If
                        Next k

                        If anniv <> "" Then
                            anniv = Left(anniv, Len(anniv) - 3)
                            fc.Cells(derlig - 1, col) = "Anniversaire de :"
                            fc.Cells(derlig, col) = vbCrLf & anniv
                            fc.Cells(derlig, col).VerticalAlignment = xlTop
                        End If

                    End With

                    col = col + 1

                Next i

            End If
        End With
    Next fc
  
'    Worksheets("Paramètre").Activate

End Function

alléluia 😉 😉 😉

Merci Beaucoup
 
Il y a toujours ta Function SemISO qui n'est pas utile et que tu peux donc supprimer pour simplifier le code global.

Tu mets simplement
VB:
.Cells(1, 2 + i).Value = "Semaine " & Format(DateSerial(année, Mois, i), "ww", vbMonday, vbFirstFourDays)
dans ta partie "Fusion Numéro de semaine", et ça fera la même chose, mais plus simplement. 😉
 
- 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

Retour