XL 2016 Suppression de feuilles automatiquement à une date bien précise

[lechti591]

Bonjour,
Je cherche actuellement à mettre en place sur un fichier une suppression des feuilles qui commence par CR+(nombre) automatiquement tous les premiers de chaque mois pouvez-vous m'aider à réaliser ce code.
Merci d'avance

 

[job75]

Bonjour lechti591, bienvenue sur XLD,

Placez cette macro dans ThisWorkbook (Alt+F11) :

Private Sub Workbook_Open()
Dim s As Object
If Day(Date) > 1 Then Exit Sub
Application.DisplayAlerts = False
On Error Resume Next 'si tous les noms commencent par CR...
For Each s In Sheets
    If UCase(s.Name) Like "CR#*" Then s.Delete
Next
End Sub

Mais quid si le fichier n'est pas ouvert le 1er du mois ???

A+

 

[vgendron]

Bonjour

un essai avec ceci

Private Sub Workbook_Open()

If Day(Date) = 1 Then 'si le jour est le 1

    For Each ws In ActiveWorkbook 'pour chaque feuille du classeur
        If ws.name = "CR*" Then ws.Delete ' si son nom commence par CR, on la supprime..
    Next ws
End If
End Sub

 

[mapomme]

Bonjour @lechti591, à tous ,

Un autre essai qui devrait fonctionner même après le premier du mois.
On garde en mémoire la date de la dernière sauvegarde (nom masqué)

• si on n'a jamais sauvegardé, on demande à l'utilisateur, par précaution, s'il faut procéder à la suppression
• si on a déjà supprimé au moins une fois, tout est automatique
• on ne supprime pas deux fois dans le mois en cours si on l'a déjà fait une fois pour le mois en cours

Private Sub Workbook_Open()
Dim DerSuppr As String, Asuppr As Boolean, rep, sh
  On Error Resume Next
  DerSuppr = Replace(ActiveWorkbook.Names("DateSuppr"), "=", "")
  On Error GoTo 0

  If DerSuppr = "" Then
    Asuppr = MsgBox("pas de trace d'une ancienne suppression" & vbLf & vbLf & _
            "Doit-on supprimer les feuilles 'CR nnn' ?", _
            vbQuestion + vbYesNo + vbDefaultButton2) = vbYes
  Else
    Asuppr = Format(Date, "yyyymm") > DerSuppr
  End If

  If Asuppr Then
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Sheets
      If LCase(sh.Name) Like "cr#*" Then
        If ThisWorkbook.Sheets.Count = 1 Then
          ThisWorkbook.Worksheets.Add
          ThisWorkbook.ActiveSheet.Name = "XXX"
        End If
        sh.Delete
      End If
    Next sh
    ThisWorkbook.Names.Add Name:="DateSuppr", RefersToR1C1:=Format(Date, "yyyymm"), Visible:=False
  End If
  Application.DisplayAlerts = True
End Sub

nota: supprimer des feuilles automatiquement, c'est quelque chose que je ne ferai jamais!

 

[job75]

Re, bonsoir vgendron, mapomme,

Un peu compliqué ton code mapomme, en fait il suffit de tester la date/heure de la dernière modification du fichier (FileDateTime) :

Private Sub Workbook_Open()
If FileDateTime(Me.FullName) > DateSerial(Year(Date), Month(Date), 1) Then Exit Sub '1er du mois à 00:00
Dim s As Object
Application.DisplayAlerts = False
On Error Resume Next 'si tous les noms commencent par CR...
For Each s In Sheets
    If UCase(s.Name) Like "CR#*" Then s.Delete
Next
End Sub

A+