Microsoft 365 Ajout et Suppression Date automatique

eric72 · 1 Février 2024

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

fanch55 · 1 Février 2024

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 · 1 Février 2024

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 · 1 Février 2024

TooFatBoy à dit:
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!!!

TooFatBoy · 1 Février 2024

eric72 à dit:
il y a le 2ème point qui me bloque aussi!!!

Voui, je sais, je regarderais ce soir.

eric72 · 1 Février 2024

TooFatBoy à dit:
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:

VB:

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

fanch55 · 1 Février 2024

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 · 1 Février 2024

fanch55 à dit:

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.

TooFatBoy · 1 Février 2024

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

Phil69970 · 1 Février 2024

Bonjour à tous

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

eric72 · 1 Février 2024

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

Microsoft 365 Ajout et Suppression Date automatique

eric72

XLDnaute Accro

Pièces jointes

fanch55

TooFatBoy

XLDnaute Barbatruc

eric72

XLDnaute Accro

TooFatBoy

XLDnaute Barbatruc

eric72

XLDnaute Accro

Pièces jointes

fanch55

XLDnaute Barbatruc

eric72

XLDnaute Accro

TooFatBoy

XLDnaute Barbatruc

Phil69970

XLDnaute Barbatruc

Pièces jointes

eric72

XLDnaute Accro

Discussions similaires