Microsoft 365 Ajout et Suppression Date automatique

[eric72]

Bonjour à tous,
J'ai encore besoin de votre lumière.
J'ai un tableau TbArchive avec des dates en colonne A, à chaque ouverture je souhaiterais supprimer les dates inférieures à date d'aujourd'hui - 1 an et ajouter à la fin de mon tableau les lignes avec les dates supérieures à date aujourd'hui + 6 mois.
Exemple si date d'aujourd'hui est 01/02/2024 la 1ère date serait 02/02/2023 et la dernière 01/08/2024.
dans ma Macro SupprAjoutLigArchives

Sub SupprAjoutLigArchives()
'
Dim MaDate As Long, MaLigne As Long, NbLigne As Long
    With Sheets("Archives2")

        MaDate = DateAdd("yyyy", -1, Date)
        MaLigne = Application.Match(MaDate, .Range("a:a"), 0)
        NbLigne = MaLigne - 1
        If Not IsError(MaLigne) And NbLigne > 0 Then .Range("a2").Resize(, NbLigne).EntireRow.Delete Shift:=xlToLeft

        MaDate = DateAdd("m", 6, Date)
        MaLigne = .Range("a2").End(xlDown).Row
        NbLigne = MaDate - .Cells(MaLigne, 1).Value
        If NbLigne > 0 Then
            With .Cells(MaLigne + 1, 1).Resize(NbLigne)
                .Value = MaDate
            End With
        End If

    End With

End Sub

qui fonctionne en partie, j'ai deux soucis
1) il me supprime la ligne entière (normal je ne sais pas adapter ce code avec un tableau structuré)
2) Si le fichier n'est pas ouvert pendant 2 ou trois jours il ajoute bien des lignes mais avec la même date.
Je ne suis pas si loin du compte mais il me manque des éléments.
Merci à tous pour le coup de main 😉 😓

 

[TooFatBoy]

Bonjour,

Si tu travailles juste sur un TS, tu n'as pas forcément besoin de désigner la feuille sur laquelle tu travailles. 😉

Pour supprimer une ligne du TS, ça doit être un truc de ce genre :

range("NomDuTS")(NumLigne).delete

Si ce n'est pas exactement ça, ça te donne au moins un axe de recherche pour résoudre ton problème. 😉

 

[eric72]

Bonjour,

Si tu travailles juste sur un TS, tu n'as pas forcément besoin de désigner la feuille sur laquelle tu travailles. 😉

Pour supprimer une ligne du TS, ça doit être un truc de ce genre :

range("NomDuTS")(NumLigne).delete

Si ce n'est pas exactement ça, ça te donne au moins un axe de recherche pour résoudre ton problème. 😉

Bonjour,
Merci TooFatboy pour ta réponse mais il y a le 2ème point qui me bloque aussi!!! 🙄

 

[TooFatBoy]

il y a le 2ème point qui me bloque aussi!!! 🙄

Voui, je sais, je regarderais ce soir.

 

[eric72]

Voui, je sais, je regarderais ce soir.

Bon alors, pour la suppression des lignes, c'est impeccable, il me reste l'ajout de lignes à la fin, il ajoute bien les lignes par contre il met à 0 au lieu de mettre les dates qui suivent, ça bloque ici:

.FormulaR1C1 = "=RC[-1]+1"
                .Value = .Value

 

[fanch55]

Salut à tous,
le code corrigé ci-dessous devrait le faire :

Sub SupprAjoutLigArchives()
Dim MaDate As Long, MaLigne As Long, NbLigne As Long
      
    ' en haut du tableau -------------------------------------------
     MaDate = DateAdd("yyyy", -1, Date)
     MaLigne = Application.Match(MaDate, [TbArchive[Date]], 0)
     NbLigne = MaLigne - [TbArchive[#Headers]].Row
     If Not IsError(MaLigne) And NbLigne > 0 _
     Then [TbArchive].Rows(1).Resize(NbLigne).Delete
    
    ' en bas du tableau --------------------------------------------
     MaDate = DateAdd("m", 6, Date)
     NbLigne = MaDate - [TbArchive[Date]].Rows([TbArchive].Rows.Count)
     If NbLigne > 0 Then
         With [TbArchive[Date]].Rows([TbArchive].Rows.Count + 1).Resize(NbLigne)
             .Value = MaDate
             .FormulaR1C1 = "=R[-1]C+1"
             .Value = .Value
         End With
     End If

End Sub

 

[eric72]

Salut à tous,
le code corrigé ci-dessous devrait le faire :

Sub SupprAjoutLigArchives()
Dim MaDate As Long, MaLigne As Long, NbLigne As Long
     
    ' en haut du tableau -------------------------------------------
     MaDate = DateAdd("yyyy", -1, Date)
     MaLigne = Application.Match(MaDate, [TbArchive[Date]], 0)
     NbLigne = MaLigne - [TbArchive[#Headers]].Row
     If Not IsError(MaLigne) And NbLigne > 0 _
     Then [TbArchive].Rows(1).Resize(NbLigne).Delete
   
    ' en bas du tableau --------------------------------------------
     MaDate = DateAdd("m", 6, Date)
     NbLigne = MaDate - [TbArchive[Date]].Rows([TbArchive].Rows.Count)
     If NbLigne > 0 Then
         With [TbArchive[Date]].Rows([TbArchive].Rows.Count + 1).Resize(NbLigne)
             .Value = MaDate
             .FormulaR1C1 = "=R[-1]C+1"
             .Value = .Value
         End With
     End If

End Sub

Bonjour Fanch55,
Merci beaucoup pour cette solution, cela fonctionne nickel, en effet je n'étais pas si loin mais...
Merci encore à tous ceux qui se décarcassent pour nous aider et bonne journée.

 

[TooFatBoy]

Bon ben du coup, je ne regarderais pas ce soir. 😅

 

[Phil69970]

Bonjour à tous

A la bourre comme d'hab... mais je l'ai fait je le poste ....

 

[eric72]

Merci à tous toofatboy, fanch et Phil,
vous êtes des cracks 👍 👍 👍