XL 2021 Création agenda

Nicolas JACQUIN

XLDnaute Impliqué
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

  • Agenda v22.xlsm
    92.3 KB · Affichages: 8
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...

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
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

  • Agenda V1.2.xlsm
    119 KB · Affichages: 0

TooFatBoy

XLDnaute Barbatruc
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:

TooFatBoy

XLDnaute Barbatruc
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:

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
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
 

TooFatBoy

XLDnaute Barbatruc
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. ;)
 

Discussions similaires

Statistiques des forums

Discussions
314 121
Messages
2 106 129
Membres
109 495
dernier inscrit
jerome bonneau