AW: letzte Zeichen im Dateinamen vergleichen
19.03.2023 01:27:40
Mathias
Hallo Thomas,
Anhand deines ersten Posts habe ich mal ein kleines Makro zusammen geschrieben, dass hoffentlich das macht, was du möchtest:
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 'Der Code wird ausgeführt, bevor die Arbeitsmappe gespeichert wird.
If SaveAsUI = True Then 'Der Code läuft nur wenn das "Speichern unter..." Fenster öffnen würde. Also nicht, wenn man eine vorhandene Arbeitsmappe nur abspeichert.
Dim strName, strFullName, strPath, strFiles, strNamePart As String 'Deklarierung der Variablen, die im Code verwendet werden.
strName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) 'Der Name der Arbeitsmappe ohne Extension
Restart: 'An diesen Punkt wird gesprungen, wenn ein Fehler aufgetreten ist.
If Err.Number > 0 Then 'Wird ausgeführt, falls ein VBA-Fehler aufgetreten ist.
MsgBox Err.Description, vbExclamation, "Microsoft Excel" 'Anzeige der Beschreibung des Fehlers
Err.Clear 'Reset der Fehlerbehandlung
On Error GoTo 0 'Reset der Fehlerbehandlung
End If
strFullName = Application.GetSaveAsFilename(strName, "Excel-Arbeitsmappe (*.xlsx), *.xlsx,Excel-Arbeitsmappe mit Makros (*.xlsm), *.xlsm") 'Hier wird das "Speichern unter..." Fenster geöffnet. (Man kann als xlsx oder xlsm speichern)
If VarType(strFullName) = 8 Then 'Falls das "Speichern unter..." Fenster geschlossen wird, wird nichts gemacht.
If MsgBox("Die folgenden Features können in Arbeitsmappen ohne Makros nicht gespeichert werden:" & vbNewLine & vbNewLine & Chr(149) & " VB Projekt" & vbNewLine & vbNewLine & _
"Zum Speichern einer Datei mit diesen Features klicken Sie auf 'Nein'. Wählen Sie dann einen Dateityp mit aktivierten Makros in der Liste 'Dateityp' aus." & vbNewLine & vbNewLine & _
"Klicken Sie auf 'Ja', um die Datei als Arbeitsmappe ohne Makros zu speichern.", vbInformation + vbYesNo, "Microsoft Excel") = 7 Then GoTo Restart 'Der Hinweis wenn mein eine Arbeitsmappe mit Makro als xlsx speichern will.
strPath = Left(strFullName, InStrRev(strFullName, "\")) 'Hier wird der Pfad vom Ordner extrahiert. (wo die Datei gespeichert werden soll)
strNamePart = GetNamePart(strFullName)
strName = GetName(strFullName)
strFiles = Dir(strFullName) 'Hier wird geprüft, ob die Datei bereits existiert.
If strFiles = "" Then 'Dieser Code wird ausgeführt, wenn die Datei noch nicht existiert.
strFiles = Dir(strPath)
While strFiles > "" 'Hier wird durch alle Dateien im Ordner geschleift.
If strNamePart = GetNamePart(strFiles) Then 'Hier wird geprüft, ob die Dokumentennummer bereits existiert.
MsgBox "Diese Dokumentennummer existiert bereits. Bitte wählen Sie eine andere Dokumentennummer aus.", vbExclamation, "Dokumentennummer bereits vorhanden!" 'Meldung, dass die Dokumentennummer bereits existiert.
GoTo Restart 'Springt zurück um einen neuen Dateinamen auszuwählen.
End If
strFiles = Dir 'Gehört zur Schleife
Wend 'Gehört zur Schleife
On Error GoTo Restart 'Wenn ein VBA-Fehler kommt, soll eine Meldung erscheinen und nochmal gestartet werden.
SaveWorkbook (strFullName)
Else
If MsgBox(strName & "." & GetExtension(strFullName) & " ist bereits vorhanden." & vbNewLine & "Möchten Sie sie ersetzen?", _
vbExclamation + vbYesNo + vbDefaultButton2, "Speichern unter bestätigen") = 7 Then GoTo Restart 'Meldung falls die Datei bereits existiert.
On Error GoTo Restart 'Wenn ein VBA-Fehler kommt, soll eine Meldung erscheinen und nochmal gestartet werden.
SaveWorkbook (strFullName)
End If
End If
Cancel = True 'Unterdrückt das eigentliche "Speichern unter..." Fenster.
End If
End Sub
Private Sub SaveWorkbook(ByVal strFileName As String) 'Diese Methode speichert die Datei ab.
Application.DisplayAlerts = False 'Unterdrückt die normalen Speicher Meldungen, da diese im Code behandelt werden.
Select Case GetExtension(strFileName)
Case "xlsx"
ActiveWorkbook.SaveAs fileName:=strFileName, FileFormat:=51, ConflictResolution:=2
Case "xlsm"
ActiveWorkbook.SaveAs fileName:=strFileName, FileFormat:=52, ConflictResolution:=2
End Select
Application.DisplayAlerts = True
End Sub
Private Function GetName(ByVal strFullName As String) As String 'Gibt den ausgewählten Dateinamen ohne Extension zurück.
strFullName = Right(strFullName, Len(strFullName) - InStrRev(strFullName, "\"))
GetName = Left(strFullName, InStrRev(strFullName, ".") - 1)
End Function
Private Function GetNamePart(ByVal strFullName As String) As String 'Gibt die Dokumentennummer zurück.
GetNamePart = Right(Left(strFullName, InStrRev(strFullName, ".") - 1), 11)
End Function
Private Function GetExtension(ByVal strFullName As String) As String 'Gibt die FileExtension zurück.
GetExtension = Right(strFullName, Len(strFullName) - InStrRev(strFullName, "."))
End Function
Dies fügst du im VBA Editor in "DieseArbeitsmappe" ein.
Der Code läuft nur, wenn die Arbeitsmappe mit dem "Speichern unter..." Fenster gespeichert werden soll. Also nicht, wenn du einfach nur auf "Save" drückst um Änderungen zu speichern.
Du kannst nur noch im xlsx oder im xlsm Format speichern. Natürlich kannst du das bei Bedarf noch erweitern.
Der Code schaut jetzt auf keine Zelle. Das müsstets du selbst mit rein programmieren.
Es öffnet sich ein "Speichern unter..." Fenster wo du wie gewohnt auswählen musst wo und mit welchem Namen die Arbeitsmappe gespeichert werden soll.
Die Arbeitsmappe wird vom Code gespeichert. Das eigentliche "speichern unter..." von Excel selbst wird nicht mehr ausgeführt.
Es wird dann in dem Ordner, wo die Arbeitsmappe gespeichert werden soll, geprüft, ob die Dokumentennummer bereits vorhanden ist.
Die Dokumentennummer wird aus dem angegebenen Namen extrahiert.
Ich hoffe, dass das annähernd so ist, wie du es haben wolltest und das du es schaffst dort die Variable aus deiner Zelle einzubringen.
Gerne versuch ich dir weiter zu helfen, falls du noch Probleme hast.
Liebe Grüße
Mathias