AW: Hier der Code
14.01.2025 17:14:22
volti
Hallo Sigrid,
hast Du Deinen Code denn auch mal getestet?
Einmal Pfad D:__Rechnung und einmal Pfad D:__Rechnungen
akp wird gesetzt, aber nie benutzt usw.
Benutzte am besten aussagekräftige Variablennamen, sonst geht einem der Durchblick verloren.
Warum wird die Originaldatei nach dem Speichern in anderem Ordner überhaupt wieder aufgemacht? Kann man doch gleich weglöschen.
Was ist, wenn der Zielpfad nicht vorhanden ist?
Hier mal eine angepasste Lösung, vielleicht passt sie ja.
Hierbei wäre der Code in einer Extradatei, also nicht in der Rechnungsdatei...
Code:
Option Explicit
Sub Speicherung_in_Rechnungs_Ausgaenge()
Const csHead = "Rechnung prüfen und speichern"
Dim sPathNeu As String, sDateiNeu As String
Dim sAktDateiname As String
If ActiveWorkbook Is ThisWorkbook Then
MsgBox "Bitte eine Rechnungsdatei öffnen!", vbExclamation, csHead
Exit Sub
End If
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
sAktDateiname = ActiveWorkbook.FullName ' Name der aktven Mappe
ActiveWorkbook.Save ' aktuelle Datei noch mal speichern
' In P32 ist der Dateiname, hiermit wird die aktuelle neue Rechnung gespeichert
sDateiNeu = Tabelle1.Range("P32").Value & " " & "Rg.-Nr. " _
& ActiveSheet.Range("H24") & " " & ActiveSheet.Range("E23") & ".xlsm"
sPathNeu = "D:\__Rechnungen\#_RechnungenNeu\##_Rechnungs_Ausgaenge_Excel\" ' Speicherungspfad für neue Rechnung
If Dir$(sPathNeu, 16) <> "" Then
ActiveWorkbook.SaveAs Filename:=sPathNeu & sDateiNeu, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False ' Datei neu abspeichern
ActiveWorkbook.Close ' Neue Datei wieder schließen
Workbooks.Open Filename:=sAktDateiname ' Orginal Rechnungsvorlage wieder öffnen
On Error Resume Next
ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly ' Schreibeschützt machen
Kill ActiveWorkbook.FullName ' und löschen
Else
MsgBox "Der Speicherpfad ist nicht vorhanden!", vbCritical, csHead
End If
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz