XL 2021 Création agenda

Nicolas JACQUIN

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
Phil69970
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...
Trier par date Trier par votes
Nicolas JACQUIN

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
Vote positif 0 Vote négatif
TooFatBoy

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:
Vote positif 0 Vote négatif
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
TooFatBoy à dit:
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
Cliquez pour agrandir...

alléluia ;) ;) ;)

Merci Beaucoup
 
Vote positif 0 Vote négatif
TooFatBoy

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. ;)
 
Vote positif 0 Vote négatif

Discussions similaires

jeff1494
  • Question
XL 2021 Création d'un Tableau croisé dynamique en évitant de charger certaines lignes.
Réponses
4
Affichages
237
jeff1494
jeff1494
J
  • Question
XL 2016 Tableau structuré avec UserForm dans classeur multipages
Réponses
2
Affichages
305
jorge1201
J
R
  • Question
Microsoft 365 "concatener" certaines colonnes d'onglets
Réponses
13
Affichages
491
rastafouette
R
A
  • Résolu(e)
XL 2021 Céer un fichier (.text) avec VBA pour enregistrer les évènements dans un journal
Réponses
4
Affichages
326
arnoldbrice19
A
B
  • Résolu(e)
XL 2013 Barre de progression.
Réponses
7
Affichages
629
fanfan38
fanfan38
T
  • Question
XL 2019 [vba] retourner une chaine de caractères depuis une fonction
Réponses
5
Affichages
239
teclim
T
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
750
Nicolas JACQUIN
Nicolas JACQUIN
philsogood
  • Question
XL 2019 conversion de cellules
Réponses
5
Affichages
446
Dranreb
Dranreb
A
  • Résolu(e)
XL 2016 Plage de données fixes pour calcul dans formule
Réponses
3
Affichages
280
sylvanu
sylvanu
Frederic14
  • Question
XL 2019 RESOLU Classeur a données croisées
Réponses
11
Affichages
327
Frederic14
Frederic14

Membres actuellement en ligne

8 membres et 94 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 013
Messages
2 104 545
Membres
109 073
dernier inscrit
hichamkot