Workbook_BeforeClose garde que 3 dernier fichiers
n
Bonjour,
J'ai fait un code qui m'enregistre chaque fois quand je ferme le fichier une copie du fichier avec la date dans un dossier Backup, le code marche impeccable, il fait ce qu'on lui demande.
La question est comment je puisse garde que trois dernier fichiers dans ce répertoire Backup, en clair faire une purge automatique en gardent que 3 dernier fichier.
Mon code :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Chemin As String, Fichier As String, sDateTime As String, sFileName As String
Chemin = ThisWorkbook.Path & Application.PathSeparator & "Backup" & Application.PathSeparator
Fichier = ThisWorkbook.Name
With ThisWorkbook
sDateTime = " (" & Format(Now, "yyyy-mm-dd hhmm") & ").xlsm"
sFileName = Application.WorksheetFunction.Substitute _
(Chemin & Fichier, ".xlsm", sDateTime)
.SaveCopyAs sFileName
End With
End Sub
Merci pour aide
n
Est-ce que quelqu'un peut me dire si ce code est bien :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Déclaration des variables
Dim chemin As String, fichier As String, sDateTime As String, sFileName As String
Dim idx As Long, listFich() As Variant, fini As Boolean, idx_max As Integer
ReDim listFich(1 To 2, 1 To 1), tmp(2)
'Choix du dossier de Backup
chemin = ThisWorkbook.Path & Application.PathSeparator & "Backup" & Application.PathSeparator
fichier = ThisWorkbook.Name
With ThisWorkbook
sDateTime = " (" & Format(Now, "yyyy-mm-dd hhmm") & ").xlsm"
sFileName = Application.WorksheetFunction.Substitute _
(chemin & fichier, ".xlsm", sDateTime)
.SaveCopyAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Do While Len(sFileName) > 0
'Assigne la date du ficier en cours une date/heure dans une variable
idx = idx + 1
ReDim Preserve listFich(1 To 2, 1 To idx)
listFich(1, idx) = FileDateTime(sFileName)
listFich(2, idx) = asFileName
'Prend le prochain fichier dans le dossier
sFileName = Dir
Loop
'trie par dates décroissantes
Do
fini = True
For idx = 1 To UBound(listFich, 2) - 1
If listFich(1, idx) < listFich(1, idx + 1) Then
tmp(1) = listFich(1, idx)
tmp(2) = listFich(2, idx)
listFich(1, idx) = listFich(1, idx + 1)
listFich(2, idx) = listFich(2, idx + 1)
listFich(1, idx + 1) = tmp(1)
listFich(2, idx + 1) = tmp(2)
fini = False
End If
Next idx
Loop Until fini
'supprime les fichiers trop ancien en ne gardant que les 3 plus récent
idx_max = Application.WorksheetFunction.Max(idx)
For idx = 3 To idx_max
If idx_max > 3 Then
Kill sFileName & listFich(2, idx_max)
End If
idx_max = Application.WorksheetFunction.Max(idx)
Next idx
End Sub
Merci
J'ai une erreur ici :
'Prend le prochain fichier dans le dossier
sFileName = Dir
n
Voici le code qui marche pour ceux qui cherchent la même chose que moi :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Déclaration des variables
Dim chemin As String, fichier As String, sDateTime As String, sFileName As String, MonFichier As String
Dim idx As Long, listFich() As Variant, fini As Boolean, idx_max As Integer
ReDim listFich(1 To 2, 1 To 1), tmp(2)
'Choix du dossier de Backup
chemin = ThisWorkbook.Path & Application.PathSeparator & "Backup" & Application.PathSeparator
fichier = ThisWorkbook.Name
With ThisWorkbook
sDateTime = " (" & Format(Now, "yyyy-mm-dd hhmm") & ").xlsm"
sFileName = Application.WorksheetFunction.Substitute _
(chemin & fichier, ".xlsm", sDateTime)
.SaveCopyAs sFileName
End With
'Prend le premier fichier depuis le dossier de Backup
MonFichier = Dir(chemin & "*.xls", vbNormal)
'MonFichier = Dir(sFileName, vbNormal)
Do While Len(MonFichier) > 0
'Assigne la date du ficier en cours une date/heure dans une variable
idx = idx + 1
ReDim Preserve listFich(1 To 2, 1 To idx)
listFich(1, idx) = FileDateTime(chemin & MonFichier)
listFich(2, idx) = MonFichier
'Prend le prochain fichier dans le dossier
MonFichier = Dir
Loop
'trie par dates décroissantes
Do
fini = True
For idx = 1 To UBound(listFich, 2) - 1
If listFich(1, idx) < listFich(1, idx + 1) Then
tmp(1) = listFich(1, idx)
tmp(2) = listFich(2, idx)
listFich(1, idx) = listFich(1, idx + 1)
listFich(2, idx) = listFich(2, idx + 1)
listFich(1, idx + 1) = tmp(1)
listFich(2, idx + 1) = tmp(2)
fini = False
End If
Next idx
Loop Until fini
'supprime les fichiers trop ancien en ne gardant que les 3 plus récent
idx_max = Application.WorksheetFunction.Max(idx)
For idx = 3 To idx_max
If idx_max > 3 Then
Kill chemin & listFich(2, idx_max)
End If
idx_max = Application.WorksheetFunction.Max(idx)
Next idx
End Sub