Das Ersetzen einer vorhandenen Datei verhindern

Question

Ich habe in meiner Excel (2013) Datei einen CommandButton "Speichern unter". Wenn ich diesen drücke, wird mir der Dateiname vorgegeben. und ich muss dann nur noch den Ordner auswählen.

Das Makro:
Sub Speichern_unter()
Dim varRetVal As Variant, strInitFileName As String, Datname As String
Dim Pfad As String
Pfad = "" 'ActiveWorkbook.Path & "\"                        '?
Datname = Range("i5") & ".xlsm"
varRetVal = Application.GetSaveAsFilename( _
InitialFileName:=Pfad & Datname, _
FileFilter:="Microsoft Excel-Dateien (*.xlsm), *.xlsm", _
Title:="Datei speichern unter... ")
If varRetVal = False Then Exit Sub
ActiveWorkbook.SaveAs varRetVal
End Sub

Wenn ich dann in dem ausgewählten Ordner auf speichern drücke, und es eine Datei mit gleichem Namen gibt, kommt die bekannte Meldung "Datei ist bereits vorhanden. Möchten Sie sie ersetzen?".
Wenn ich dann auf ja klicke, wird die vorhandene Datei überspeichert.
Ist es möglich, bei vorhandener gleichnamiger Datei, das Ersetzen nicht möglich zu machen. Zum Beispiel eine Meldung "Die Datei besteht bereits, speichern nicht möglich" und dann nur die Möglichkeit zu haben abzubrechen.

mit freundlichen Grüßen
Hans-Jörg

Answer 1

Hi Hans-Jörg,

Klar geht das. Mit dem Filesystemobjekt kannst du viele tolle Sachen machen. U.a. kannst du überprüfen ob eine Datei bereits besteht. Dein Code entsprechend angepasst sieht dann so aus:

Sub Speichern_unter()
Dim varRetVal As Variant, strInitFileName As String, Datname As String
Dim Pfad As String
Dim fs As Object
Set fs = CreateObject("Scripting.FilesystemObject")

Pfad = "" 'ActiveWorkbook.Path & "\"                        '?
Datname = Range("i5") & ".xlsm"
varRetVal = Application.GetSaveAsFilename( _
InitialFileName:=Pfad & Datname, _
FileFilter:="Microsoft Excel-Dateien (*.xlsm), *.xlsm", _
Title:="Datei speichern unter... ")
If varRetVal = False Then Exit Sub
If fs.fileexists(varRetVal) Then
  MsgBox "Datei besteht bereits, Speichern nicht möglich", vbExclamation
  Exit Sub
End If
ActiveWorkbook.SaveAs varRetVal
End Sub

Gruß Mr. K.

Answer 2

Hallo Mr. K.!

Manchmal fehlen mir die Worte.

Unglaublich, wie sowas auf einmal funktioniert.

Genau so soll es sein.

Vielen Dank für Deine Mühe!

Gruß

Hans-Jörg

Answer 3

Hi Hans-Jörg,

du brauchst nicht das externe Computer-System um zu prüfen ob eine Datei vorhanden ist - VBA stellt dafür eine  eigene Funktion zur Verfügung, und zwar Dir():

Sub Speichern_unter()
    Dim varRetVal As Variant, strInitFileName As String, Datname As String
    Dim Pfad As String
    Pfad = "" 'ActiveWorkbook.Path & "\"                        '?
    Datname = Range("i5") & ".xlsm"
    If Dir(Pfad & Datname) <> "" Then  'wenn Datei bereits vorhanden dann ist Dir(...) nicht leer
        MsgBox "Datei bereits vorhanden"
    Else
        varRetVal = Application.GetSaveAsFilename( _
            InitialFileName:=Pfad & Datname, _
            FileFilter:="Microsoft Excel-Dateien (*.xlsm), *.xlsm", _
            Title:="Datei speichern unter... ")
        If varRetVal = False Then Exit Sub
        ActiveWorkbook.SaveAs varRetVal
    End If
End Sub

Bis später, Karin

Answer 4

Super Karin!

Vielen Dank für Deine Mühe!

Ihr habt mir sehr geholfen!

Danke