VBA "versteckte Backups"
11.09.2021 20:22:21
Excel
ich möchte niemanden langweilen und komme deswegen direkt zur Sache:
Ich habe ein Excel-Zeiterfassungstool erstellt, in welchem bereits mehrere, funktionierende Makros laufen. Leider habe ich 2 Probleme:
1) Ich möchte einen VBA Code schreiben, welcher a) in dem Verzeichnis, in welchem die Excel Datei aktuell gespeichert ist einmalig einen versteckten Ordner anlegt, sofern dieser nicht schon existiert, welcher "[Backup | Zeiterfassungstools]" heißt und b) bei jedem Öffnen der Excel Datei (des Zeiterfassungstools) eine ebenfalls versteckte Backupdatei mit dem Namen "[Backup] + Name der zu sichernden Backupdatei" im Backup Ordner anlegt, welche bei jedem weiteren Öffnen der Excel Datei (des Zeiterfassungstools) überschrieben werden soll.
Folgenden Code habe ich bereits geschrieben, welcher eine Backupdatei (versteckt) anlegt...
Sub BackUp()
'Erstellt ein Backup der aktuell geöffneten Excel-Datei auf demselben Pfad
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
"\" & "[Backup]" & " " & _
ThisWorkbook.Name
'Versteckt die Backup-Datei
SetAttr ThisWorkbook.Path & _
"\" & "[Backup]" & " " & _
ThisWorkbook.Name, vbHidden
End Sub
Ich vermute das liegt daran, dass beim zweiten Öffnen des Zeiterfassungstools laut Code zuerst die Backup-Datei mit gleichem angelegt und dann erst im zweiten Schritt versteckt wird, was zu einem Konflikt wegen gleichem Namen führt und die Datei nicht mehr überschrieben werden kann, da sie bereits angelegt wurde und sich nur deren Eigenschaft (zu "versteckt") ändert. Kann aber auch an etwas anderem liegen.
Einen Ordner konnte ich auch per Code anlegen allerdings nicht versteckt, nicht einmalig (also ohne Prüfung ob ein solcher Ordner schon existiert) und die Backup-Datei wird nicht in diesem Ordner sondern leider eine Dateiebene höher erstellt/abgelegt:
Option Explicit
Sub Folder()
Dim strPfad As String
strPfad = ThisWorkbook.Path
If strPfad > "" Then
If Dir(strPfad & "\[Backups]", vbDirectory) = "" Then MkDir strPfad & "\[Backups]"
Else
MsgBox "Datei ist noch nicht gespeichert."
End If
End Sub
Diese Arbeitsmappe
Private Sub Workbook_Open()
'Öffne das Tabellenblatt des aktuellen Monats
Monat = Format(Date, "MMMM")
Worksheets(Monat).Activate
'Einen Ordner für die Backup Dateien erstellen
'Application.OnTime Now(), "Folder"
'Pro Öffnen eine versteckte Backupdatei im selben Pfad erstellen welche bei jedem nachfolgenden Öffnen überschrieben wird
Application.OnTime Now(), "BackUp"
'Sperre den letzten Monat 5 Tage nach Ablauf
Dim i As Integer
Dim dTag As Integer
For i = 1 To 12
If Weekday(DateSerial(Year(Date), i + 1, 1), 2) = 1 Then
dTag = 5
ElseIf Weekday(DateSerial(Year(Date), i + 1, 1), 2) DateSerial(Year(Date), i + 1, dTag) Then
'Hier dein Passwort anpassen
Sheets(i).Protect Password:="Test"
End If
Next
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
'Verhindere, dass neues leeres Tabellenblatt eingefügt werden kann
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Sh.Delete
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Private Sub Workbook_Open()
'Öffne das Tabellenblatt des aktuellen Monats
Monat = Format(Date, "MMMM")
Worksheets(Monat).Activate
'Sperre den letzten Monat 5 Tage nach Ablauf
Dim i As Integer
Dim dTag As Integer
For i = 1 To 12
If Weekday(DateSerial(Year(Date), i + 1, 1), 2) = 1 Then
dTag = 5
ElseIf Weekday(DateSerial(Year(Date), i + 1, 1), 2) DateSerial(Year(Date), i + 1, dTag) Then
'Hier dein Passwort anpassen
Sheets(i).Protect Password:="Test"
End If
Next
End Sub
Sub BackUp()
'Erstellt ein Backup der aktuell geöffneten Excel-Datei auf demselben Pfad
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
"\" & "[Backup]" & " " & _
ThisWorkbook.Name
'Versteckt die Backup-Datei
'SetAttr ThisWorkbook.Path & _
'"\" & "[Backup]" & " " & _
'ThisWorkbook.Name, vbHidden
End Sub
Option Explicit
Sub Folder()
Dim strPfad As String
strPfad = ThisWorkbook.Path
If strPfad > "" Then
If Dir(strPfad & "\[Backups]", vbDirectory) = "" Then MkDir strPfad & "\[Backups]"
Else
MsgBox "Datei ist noch nicht gespeichert."
End If
End Sub
Vielen Dank für eure Unterstützung und die Geduld beim lesen!
Gruß
Excel Friend