Microsoft 365 Ajout et Suppression Date automatique

eric72

XLDnaute Accro
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
VB:
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 ;) 😓
 

Pièces jointes

  • test.xlsm
    36.6 KB · Affichages: 6
Solution
Salut à tous,
le code corrigé ci-dessous devrait le faire :
VB:
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)...

TooFatBoy

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

XLDnaute Accro
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 :
VB:
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!!! :rolleyes:
 

fanch55

XLDnaute Barbatruc
Salut à tous,
le code corrigé ci-dessous devrait le faire :
VB:
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

XLDnaute Accro
Salut à tous,
le code corrigé ci-dessous devrait le faire :
VB:
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.
 

Statistiques des forums

Discussions
313 219
Messages
2 096 310
Membres
106 566
dernier inscrit
Fabiens