Fortlaufend speichern

Private Sub Workbook_AfterSave(ByVal Success As Boolean) Dim DateiSuche, Versuch Application.DisplayAlerts = False Application.EnableEvents = False Versuch = 0 DateiSuche = Dir(ThisWorkbook.Path & "\Sicherung\" & [H7].Value & Format(Now, "_DD.MM.YYYY_hh. _ mm._* ") Do Until DateiSuche = "" ' .Print DateiSuche DateiSuche = Dir() Versuch = Versuch + 1 Loop ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\Sicherung\" & [H7].Value & Format(Now, _ "_DD.MM.YYYY_hh.mm._") & Versuch & ".xlsm" Application.EnableEvents = True Application.DisplayAlerts = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Maxim,
bei mir unter Excel 365/Windows 10 funktioniert dein Makro.
Ich habe bei früheren Versionen in der Vergangenheit (wann ?) aber schon Probleme mit der Dir-Funktion gehabt, wenn im Suchstring für den Dateinamen Punkte in Verbindung mit der Wildcard * enthalten waren.
Ich hab dein Makro mal etwas umgebaut.
ggf. für den Namen der Kopie eine Variante ohne Punkte verwenden.
Der einfachere Weg wäre natürlich im Namen der Kopie die Sekunde mit einzubauen, dann kannst du dir die Prüfungen sparen.
LG
Franz

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim DateiSuche, Versuch
Dim sNameCopy As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Versuch = 0
sNameCopy = ThisWorkbook.Path & "\Sicherung\" & [H7].Value _
& Format(Now, "_DD.MM.YYYY_hh.mm._")
'alternativer Name der Kopie ohne Punkte
'    sNameCopy = ThisWorkbook.Path & "\Sicherung\" & [H7].Value _
& Format(Now, "_YYYY-MM-DD_hh_mm_")
Do
DateiSuche = Dir(sNameCopy & Versuch & ".xlsm")
' .Print DateiSuche
If DateiSuche = "" Then Exit Do
If Versuch = 60 Then 'Notausgang
MsgBox "60 Versuche zur Sicherungskopie sind gelaufen!"
GoTo Beenden
End If
Versuch = Versuch + 1
Loop
ActiveWorkbook.SaveCopyAs Filename:=sNameCopy & Versuch & ".xlsm"
Beenden:
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

ActiveWorkbook.SaveCopyAs Filename:=sNameCopy & Versuch & ".xlsm" 'Arbeitsmappe als PDF-speichern ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=sNameCopy & Versuch & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False 'aktives Blatt als PDF speichern ' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=sNameCopy & Versuch & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread