Excel Datei in einem bestimmten Verzeichnis unter einem Namen in einer Zelle speichern

Question

Hallo,

ich möchte eine geöffnete Excel Datei beim anklicken des Speichern-Symbol im Verzeichnis F:\Datensicherung\Archiv unter 2 verschiedenen Voraussetzungen speichern:

1. Speichern unter dem Namen, der im Arbeitsblatt Flächenberechnung in der Zelle D10 steht

oder

2. Wenn in der Zelle nichts steht, dann unter fortlaufender Nummer des bisherigen Dateinamens "2020 06 Berechnung"+01, +02, +... speichern. Gleiche Voraussetzung beim schließen der Datei mit dem x-Symbol oben rechts.

Ich arbeite mit Excel 365. Vielen Dank im Voraus für Eure Hilfe.

Gruß Michael

Answer 1

Hallo Michael,

ich habe dir da mal etwas gebastelt. Steht die Datei im Verzeichnis F:\Datensicherung\Archiv, dann wird sie normal gespeichert. Ansonsten wird die Datei wie von dir gewünscht gespeichert.

Kopiere die folgenden beiden Makros in das VBA-Projekt der Arbeitsmappe:

Private Sub Workbook_BeforeClose(Cancel As Boolean)

'Speichervorgang abbrechen
Cancel = True
'Makro zum automatischen Speichern aufrufen - mit Schließen der Datei
Call automatisch_speichern(True)

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

'Makro für automatische Speicherung aufrufen, falls nicht Speichern unter gewählt wurde
If SaveAsUI = False Then
  'Speichervorgang abbrechen
  Cancel = True
  'Makro zum automatischen Speichern aufrufen - ohne Schließen der Datei
  Call automatisch_speichern(False)
End If

End Sub

Das folgende Makro kopiere in ein Standardmodul:

Sub automatisch_speichern(ByVal bClose As Boolean)

Dim strPfad As String
Dim strName As String
Dim inNr As Integer

'Ereignissteuerungen ausschalten
 Application.EnableEvents = False

'Pfad festlegen
strPfad = "F:\Datensicherung\Archiv\"

'Prüfen, ob die Datei bereits im richtigen Pfad gespeichert ist
If ThisWorkbook.Path & "\" = strPfad Then
   'falls ja, dann
   If bClose = True Then
     'Arbeitsmappe speichern und schließen, falls Mappe geschlossen werden sollte
     ThisWorkbook.Close (True)
    Else
     'andernfalls nur speichern
      ThisWorkbook.Save
   End If
  'Ereignissteuerungen einschalten
  Application.EnableEvents = True
  'Makro verlassen
   Exit Sub
End If

'andernfalls im neuen Verzeichnis speichern
'Name aus Zelle D10 im Arbeitsblatt Flächenberechnung einlesen
strName = ThisWorkbook.Worksheets("Flächenberechnung").Range("D10").Value

'falls Zelle D10 nicht leer ist, dann unter dem Namen in Zelle D10 im neuen Pfad speichern
If strName <> "" Then
  If Right(strName, 5) <> ".xlsm" Then strName = strName & ".xlsm"
  With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
       'ggf. schließen
       If bClose = True Then .Close
  End With
  'Ereignissteuerungen einschalten
  Application.EnableEvents = True
  'Makro verlassen
  Exit Sub
End If

'Datei unter aktuellem Namen speichern
strName = ThisWorkbook.Name

'Prüfen, ob Datei mit dem Namen schon vorhanden ist
If Dir(strPfad & strName) = "" Then
  'nein, unter dem Dateinamen speichern
   With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
      'ggf. schließen
       If bClose = True Then .Close
  End With
  'Makro verlassen
End If

'Dateiname schon vorhanden, daher neuen Dateinamen generieren
Do Until Dir(strPfad & strName) = ""
  intNr = intNr + 1
  If intNr < 10 Then
    strName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "0" & intNr & ".xlsm"
   Else
    strName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & intNr & ".xlsm"
  End If
Loop

'speichern
With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
       'ggf. schließen
       If bClose = True Then .Close
  End With

End Sub

Du kannst die Datei immer noch mit "Speichern unter" speichern, hier greift das Makro nicht.

Schau mal, ob das so funktioniert, wie du willst.

Gruß

M.O.

Answer 2

Hallo M. O.

vielen lieben Dank für Deine Mühe. Ich hab im Moment noch keine Zeit es auszuprobieren. Ich melde mich, sobald ich es getestet habe.

Viele Grüße

Michael

Answer 3

Hallo M. O.

funktioniert soweit schon mal sehr gut. ganz prima. Einziges Problem ist, dass nach dem Schließen der Datei Excel nicht komlett schließt und ein "graues Feld" stehen bleibt, dass ich dann über die Taskleiste schliessen muss. ...und das mit dem 'Dateiname schon vorhanden, daher neuen Dateinamen generieren funktioniert leider auch noch nicht.

Viele Grüße Michael

Answer 4

Hallo,

was klappt denn beim Speichern mit einem neuen Dateinamen nicht? Bei meiner Testdatei klappt das einwandrei.

Gruß

M.O.

Answer 5

Hallo M.O.,

ich habe den Pfad und die Zelle wie folgt geändert:

Sub automatisch_speichern(ByVal bClose As Boolean)

Dim strPfad As String
Dim strName As String
Dim inNr As Integer

'Ereignissteuerungen ausschalten
 Application.EnableEvents = False

'Pfad festlegen
strPfad = "F:\Datensicherung\Geschaeft\Kunden Angebote\AAA Berechnungen\"

'Prüfen, ob die Datei bereits im richtigen Pfad gespeichert ist
If ThisWorkbook.Path & "\" = strPfad Then
   'falls ja, dann
   If bClose = True Then
     'Arbeitsmappe speichern und schließen, falls Mappe geschlossen werden sollte
     ThisWorkbook.Close (True)
    Else
     'andernfalls nur speichern
      ThisWorkbook.Save
   End If
  'Ereignissteuerungen einschalten
  Application.EnableEvents = True
  'Makro verlassen
   Exit Sub
End If

'andernfalls im neuen Verzeichnis speichern
'Name aus Zelle C3 im Arbeitsblatt Flächenberechnung einlesen
strName = ThisWorkbook.Worksheets("Flächenberechnung").Range("C3").Value

'falls Zelle C3 nicht leer ist, dann unter dem Namen in Zelle C3 im neuen Pfad speichern
If strName <> "" Then
  If Right(strName, 5) <> ".xlsm" Then strName = strName & ".xlsm"
  With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
       'ggf. schließen
       If bClose = True Then .Close
  End With
  'Ereignissteuerungen einschalten
  Application.EnableEvents = True
  'Makro verlassen
  Exit Sub
End If

'Datei unter aktuellem Namen speichern
strName = ThisWorkbook.Name

'Prüfen, ob Datei mit dem Namen schon vorhanden ist
If Dir(strPfad & strName) = "" Then
  'nein, unter dem Dateinamen speichern
   With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
      'ggf. schließen
       If bClose = True Then .Close
  End With
  'Makro verlassen
End If

'Dateiname schon vorhanden, daher neuen Dateinamen generieren
Do Until Dir(strPfad & strName) = ""
  intNr = intNr + 1
  If intNr < 10 Then
    strName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "0" & intNr & ".xlsm"
   Else
    strName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & intNr & ".xlsm"
  End If
Loop

'speichern
With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
       'ggf. schließen
       If bClose = True Then .Close
  End With

End Sub

Meine Datei heißt "Berechnung"

Wenn ich in die Zelle C3 einen Namen eingebe, wird die Datei auch im Pfad unter dem Namen gespeichert. Wenn ich jetzt diese Datei  in dem Pfad aufrufe und erneut speichern (oben links auf das Diskettensymbol) klicke, wird nur die bestehende Datei überschrieben...

Wenn ich die Datei OHNE eine Eingabe im Feld C3 abspeichere, erscheint in den zu speichernden Pfad eine Datei mit Berechnung.xlsm und gleichzeitig eine Datei Berechnung01.xlsm. Bei jedem weiteren anklicken von speichern wird die Datei Berechnung01.xlsm nur überschrieben. Wenn ich in dem Pfad die Datei Berechnung01.xlsm anklicke und dann auf speichern gehe, wird auch nur die Datei Berechnung01.xlsm überschrieben. Grüße Michael

Answer 6

Hallo Michael,

ich war davon ausgegangen, dass die Datei nur unter neuem Namen gespeichert werden, wenn diese nicht in dem vorgegebenen Pfad steht. Aber das lässt sich einfach ändern.

Du schreibst:

Wenn ich in die Zelle C3 einen Namen eingebe, wird die Datei auch im Pfad unter dem Namen gespeichert. Wenn ich jetzt diese Datei  in dem Pfad aufrufe und erneut speichern (oben links auf das Diskettensymbol) klicke, wird nur die bestehende Datei überschrieben...

Soll das heißen, dass wenn in C3 ein Name steht und du auf das Speichern- oder Schließen-Symbol drückst, die Datei auch mit dem Suffix 01 etc. gespeichert werden soll? Das war so aus deiner Frage nicht zu erkennen.

Und soll in diesem Fall beim Schließen auch ein neuer Dateiname generiert werden?

Gruß

M.O.

Answer 7

Hallo M. O. Ja, genau das war der Plan. Sorry, wenn ich es nicht so richtig erklärt habe...

Answer 8

Hallo Michael,

ändere das Makro im allgemeinen Modul mal wie folgt:

Sub automatisch_speichern(ByVal bClose As Boolean)

Dim strPfad As String
Dim strName As String
Dim intNr As Integer

'Ereignissteuerungen ausschalten
 Application.EnableEvents = False

'Pfad festlegen
strPfad = "F:\Datensicherung\Geschaeft\Kunden Angebote\AAA Berechnungen\"

'Name aus Zelle C3 im Arbeitsblatt Flächenberechnung einlesen
strName = ThisWorkbook.Worksheets("Flächenberechnung").Range("C3").Value

'falls Zelle C3 nicht leer ist, dann unter dem Namen in Zelle C3 im neuen Pfad speichern
If strName <> "" Then
  If Right(strName, 5) <> ".xlsm" Then strName = strName & ".xlsm"
  With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
       'ggf. schließen
       If bClose = True Then .Close
  End With
  'Ereignissteuerungen einschalten
  Application.EnableEvents = True
  'Makro verlassen
  Exit Sub
End If

'Datei unter aktuellem Namen speichern
strName = ThisWorkbook.Name

'Prüfen, ob Datei mit dem Namen schon vorhanden ist
If Dir(strPfad & strName) = "" Then
  'nein, unter dem Dateinamen speichern
   With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
      'ggf. schließen
       If bClose = True Then .Close
  End With
   'Ereignissteuerungen einschalten
  Application.EnableEvents = True
  'Makro verlassen
  Exit Sub
End If

'Dateiname schon vorhanden, daher neuen Dateinamen generieren
'prüfen, ob Dateiname mit Zahl endet
If IsNumeric(Mid(strName, Len(strName) - 6, 2)) Then
  'und falls ja, dann Zahl in Zähler für Name schreiben
  intNr = CInt(Mid(strName, Len(strName) - 6, 2))
  'sowie Zahl aus Dateinamen entfernen
  strName = Left(strName, Len(strName) - 7) & ".xlsm"
End If

'neuen Dateinamen generieren
Do Until Dir(strPfad & strName) = ""
  intNr = intNr + 1
  If intNr < 10 Then
    strName = Left(strName, Len(strName) - 5) & "0" & intNr & ".xlsm"
   Else
    strName = Left(strName, Len(strName) - 5) & intNr & ".xlsm"
  End If
Loop

'speichern
With ThisWorkbook
      'speichern unter
      .SaveAs Filename:=strPfad & strName
       'ggf. schließen
       If bClose = True Then .Close
  End With

 'Ereignissteuerungen einschalten
  Application.EnableEvents = True

End Sub

Schau mal, ob das dann so funktioniert, wie du willst.

Gruß

M.O.

Answer 9

Hallo M.O. ich möchte Deine kostbare Zeit nicht zuviel in Anspruch nehmen, aber leider funktioniert es nicht....

Ich habe das Letzte Modul wie oben beschrieben aktualisiert

Ich versuche, es nochmal zu erklären. Wenn ich im Verzeichnis F:\Datensicherung\Geschaeft\Listen Excel\Excel Preisliste die Datei 2020 07 Berechnung öffne, einen Namen (z.B. Michael) in der Zelle Flächenberechnung C3 vergebe, dann oben auf das Diskenntensymbol klicke, wird die Datei Michael im Verzeichnis F:\Datensicherung\Geschaeft\Kunden Angebote\AAA Berechnungen\ gespeichert. Wenn ich jetzt wieder die Datei öffne und erneut den Namen Michael verwende, anschließend auf das Speichern Symbol klicke, kommt die Meldung, dass die Datei  im Verzeichnis F:\Datensicherung\Geschaeft\Kunden Angebote\AAA Berechnungen\ bereits vorhanden ist und ob sie ersetzt werden soll. Wenn ich auf Nein klicke, kommt ein Laufzeitfehler 1004. Wenn ich im Verzeichnis F:\Datensicherung\Geschaeft\Kunden Angebote\AAA Berechnungen\ die Datei Michael öffne und auf das Speichernsymbol klicke wird die Datei nur überschrieben.

Grüße Michael