AW: Maximal 5 Sicherungskopien
11.11.2018 20:19:13
Sepp
Hallo Ray,
im VBE unter 'Extras' > 'Verweise' den verweis auf die 'Microsoft Scripting Runtime' setzen!
Microsoft Excel Objekt DieseArbeitsmappe
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim SavePath As String, FileName As String, FileExtension As String
Dim FileDate As String, FileBackupName As String, FileUsername As String
Dim strFile As String, lngCount As Long, objDic As New Scripting.Dictionary
SavePath = ThisWorkbook.Path & "\Backup\"
FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
FileExtension = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") + 1)
FileUsername = Environ("UserName")
FileDate = Format(Now, "YYYYmmdd_hhmmss")
strFile = Dir(SavePath & "*" & FileUsername & "*" & FileExtension, vbNormal)
Do While strFile <> ""
objDic.Add Key:=FileDateTime(SavePath & strFile), Item:=SavePath & strFile
strFile = Dir
Loop
If objDic.Count > 5 Then
Set objDic = SortDictionaryByKey(objDic, xlDescending)
For lngCount = 5 To objDic.Count - 1
Kill objDic.Items(lngCount)
Next
End If
FileBackupName = SavePath & FileName & "_" & FileUsername & "_" & FileDate & "." & FileExtension
ActiveWorkbook.SaveCopyAs FileBackupName
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0
Modul Modul1
Option Explicit
Public Function SortDictionaryByKey(dict As Object _
, Optional sortorder As XlSortOrder = xlAscending) As Object
'© https://excelmacromastery.com/vba-dictionary/
Dim arrList As Object
Set arrList = CreateObject("System.Collections.ArrayList")
' Put keys in an ArrayList
Dim Key As Variant, coll As New Collection
For Each Key In dict
arrList.Add Key
Next Key
' Sort the keys
arrList.Sort
' For descending order, reverse
If sortorder = xlDescending Then
arrList.Reverse
End If
' Create new dictionary
Dim dictNew As Object
Set dictNew = CreateObject("Scripting.Dictionary")
' Read through the sorted keys and add to new dictionary
For Each Key In arrList
dictNew.Add Key, dict(Key)
Next Key
' Clean up
Set arrList = Nothing
Set dict = Nothing
' Return the new dictionary
Set SortDictionaryByKey = dictNew
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0