hier mal eine Variante
27.11.2020 15:05:48
Tino
Hallo,
hier mal eine Variante.
Wenn die Vorlage selbst gespeichert wird,
wird der Pfad als benutzerdefinierte Dokumenteigenschaft gespeichert.
Bevor du die Vorlage speicherst, diesen Code hinterlegen.
Code in DieseArbeitsmappe
Option Explicit
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim CP As Object
If ThisWorkbook.FullName Like "*.xlt?" Or ThisWorkbook.FullName Like "*.xlt" Then
For Each CP In ThisWorkbook.CustomDocumentProperties
If CP.Name = "FullPath" Then CP.Delete: Exit For
Next
ThisWorkbook.CustomDocumentProperties.Add Name:="FullPath", _
LinkToContent:=False, _
Type:=msoPropertyTypeString, _
Value:=ThisWorkbook.FullName
Application.EnableEvents = False
ThisWorkbook.Save
Application.EnableEvents = True
End If
End Sub
Code in Tabelle1
Option Explicit
Private Sub CommandButton1_Click()
Call SaveSpezial
End Sub
Code in ein Modul
Option Explicit
Sub SaveSpezial()
Dim CP As Object, sPath$, sName$, sSaveFullName$
For Each CP In ThisWorkbook.CustomDocumentProperties
If CP.Name = "FullPath" Then Exit For
Next
If CP Is Nothing Then
MsgBox "kein Pfad aus Vorlage!", vbExclamation
Exit Sub
End If
sPath = Left$(CP, InStrRev(CP, "\"))
sName = Right$(CP, Len(CP) - InStrRev(CP, "\"))
With Tabelle1
sSaveFullName = sPath & .Range("H1").Value & .Range("L1").Value & ".xlsx"
End With
If Dir(sSaveFullName, vbNormal) "" Then
If MsgBox("Datei mit den Namen bereits vorhanden!" & vbCr & _
"Soll diese ersetzt werden?" & vbCr & _
sSaveFullName, vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
End If
Application.DisplayAlerts = False
Application.EnableEvents = False
ThisWorkbook.SaveAs Filename:=sSaveFullName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
Application.EnableEvents = True
Workbooks.Open sPath & sName
ThisWorkbook.Close False
End Sub