EXCEL - Sicherungskopie via VBA

EXCEL - Sicherungskopie via VBA (6 Beiträge, 121 Mal gelesen)

Du bist nicht angemeldet. [ Login/Registrieren ]

Hallo!

Ich würde gerne eine Excel-Mappe per Makro dazu bewegen lassen, dass diese Mappe zusätzlich zum Stammverzeichnis auch noch in ein anderes Verzeichnis gespeichert wird. Also eine Sicherungskopie

Bis dato habe ich diese jedoch noch nicht geschafft....vielleicht kann mir jemand helfen?

lG und thx

SunnyHill

Ich wollte nur mal sagen, dass ich es nun doch geschafft habe....

thx, SunnyHill.

hier der Code, im Personal Workbook speichern und dann einen Knopf hinzufügen (so hab ichs gemacht):

Public Sub Speichern()
Dim strPath As String, strFile As String
Dim arrfiles As Variant
Dim intCounter As Integer, intMax As Integer, intCount As Integer, intTmp As Integer
Dim datMax As Date

strFile = Mid(ActiveWorkbook.Name, 1, Len(ActiveWorkbook.Name) - 4)
strPath = ActiveWorkbook.path & "\" & strFile & "_temp"
If Dir(strPath, vbDirectory) = "" Then
    MkDir (strPath)
End If
strPath = strPath & "\"

With Application.FileSearch
    .NewSearch
    .LookIn = strPath
    .FileName = "*" & strFile & "*.xls"
    .Execute msoSortByLastModified, msoSortOrderAscending
    If .FoundFiles.Count = 3 Then
        intTmp = Mid(.FoundFiles.Item(1), Len(.FoundFiles.Item(1)) - 5, 1)
        Kill (.FoundFiles.Item(1))
        Application.StatusBar = "Datei wird als " & strPath & strFile & intTmp & ".xls gespeichert"
        ActiveWorkbook.SaveCopyAs (strPath & strFile & intTmp & ".xls")
        Application.StatusBar = ""
    ElseIf .FoundFiles.Count = 0 Then
        Application.StatusBar = "Datei wird als " & strPath & strFile & 1 & ".xls gespeichert..."
        ActiveWorkbook.SaveCopyAs (strPath & strFile & 1 & ".xls")
        Application.StatusBar = ""
    Else
        intTmp = (Mid(.FoundFiles.Item(.FoundFiles.Count), Len(.FoundFiles.Item(.FoundFiles.Count)) - 4, 1)) + 1
        Application.StatusBar = "Datei wird als " & strPath & strFile & intTmp & ".xls gespeichert..."
        ActiveWorkbook.SaveCopyAs (strPath & strFile & intTmp & ".xls")
        Application.StatusBar = ""
    End If

End With
ActiveWorkbook.Save
End Sub

Ich habs noch so gemacht dass immer nur max. 3 Sicherungskopien aufgehoben werden.

mfg

Penguin

Hallo!

Danke für deine (bessere) Lösung als die meinige!

Ich habe in stümperhaften VBA mein Problem folgend gelöst:

Sub DateiSpeichern()
Dim Nr%
Dim dName$
Dim Zielordner$, Dateiname$

Zielordner = "p:\vorlagen\Sicherung\"

Dateiname = Format(Now, "dd.mm.yyyy") & "_Sicherung"

dName = Zielordner & Dateiname & ".ini"

Close

On Error Resume Next
Open dName For Input As #1
If Err > 0 Then
    Nr = 1
    Close
    Open dName For Output As #1
    Print #1, Format(Nr, "00#")
    Close
    Exit Sub
Else
    Input #1, Nr
    Close
    Open dName For Output As #1
    Print #1, Format(Nr + 1, "00#")
    Close
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Zielordner & Dateiname & Nr & ".xls"
Application.DisplayAlerts = True
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=("p:\statistik\SG-Kartei und Statistik " & Format(Now, "yyyy") & ".xls")
Application.DisplayAlerts = True

If MsgBox("Die Datei sowie die Sicherungskopie wurde ordnungsgemäß gespeichert!", vbInformation + vbOKOnly, "....gespeichert!") = vbOK Then Exit Sub

Ist zwar auch nicht schlecht

aber ich werde deine Variante nehmen, da diese eine definierbare Menge an Sicherungen zulässt und obendrein sauber programmiert ist |-)

Nochmals danke!

lG, SunnyHill

das einzige was mich ein bisschen an meiner Lösung nervt (die hab ich allerdings schon vor glaub ich 2 Jahren gemacht) ist dass sie immer FileSearch verwendet, was bei großen Ordnern langsam ist. Muss mir das direkt mal wieder anschauen.

mfg

Penguin

Bitte schen:

Public Sub Speichern_test()
Dim strPath As String, strFile As String, strMin As String, strBackup As String
Dim intCounter As Integer, intMax As Integer
Dim datMax As Date
Dim fso As Object

intMax = 3 'maximale Anzahl an Backups
strBackup = "\backup" 'sub-Verzeichnis für Backups

datMax = Now 'Startwert für Überprüfung
ActiveWorkbook.Save 'Speichern
strFile = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) 'Dateiname
strPath = ActiveWorkbook.Path & strBackup 'Backup-Pfad
If Dir(strPath, vbDirectory) = "" Then 'existiert backup-Pfad?
    MkDir (strPath) 'Nein -> erstellen'
    ActiveWorkbook.SaveCopyAs strPath & "\" & strFile & "_backup1.xls" 'zugleich backup speichern und fertig
Else
    strPath = strPath & "\" 'Pfad korrigieren
    For intCounter = 1 To intMax 'anzahl an Backups durchlaufen
        If Dir(strPath & strFile & "_backup" & intCounter & ".xls") <> "" Then 'Prüfen obs schon existiert
            Set fso = CreateObject("Scripting.Filesystemobject") 'Zeiger erzeugen
            If fso.GetFile(strPath & strFile & "_backup" & intCounter & ".xls").DateLastModified < datMax Then 'Datei-Modified Datum auslesen und kleinstes suchen
                datMax = fso.GetFile(strPath & strFile & "_backup" & intCounter & ".xls").DateLastModified
                strMin = strPath & strFile & "_backup" & intCounter & ".xls"
            End If
            Set fso = Nothing
        Else
            ActiveWorkbook.SaveCopyAs strPath & strFile & "_backup" & intCounter & ".xls" 'noch nicht maximale Anzahl an Backups, dann eine erzeugen
            Exit Sub
        End If
    Next intCounter
    'Kill strMin 'alte löschen braucht man nicht wirklich
    ActiveWorkbook.SaveCopyAs strMin 'Backup speichern
End If
End Sub

mfg

Penguin

Dieses Forum ist eine frei zugängliche Diskussionsplattform.
Der Betreiber übernimmt keine Verantwortung für den Inhalt der Beiträge und behält sich das Recht vor, Beiträge mit rechtswidrigem oder anstößigem Inhalt zu löschen.
Datenschutzerklärung