239 Aufrufe
Gefragt in Tabellenkalkulation von mherborn Einsteiger_in (36 Punkte)
Bearbeitet von mherborn
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

2 Antworten

0 Punkte
Beantwortet von m-o Profi (17.7k Punkte)

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.

0 Punkte
Beantwortet von mherborn Einsteiger_in (36 Punkte)
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
...