Datei im gleichen Ordner speichern

Hallo,
ich habe ein kleines Problem.
Ich habe eine Vorlage-Datei, mit der ich Protokolldateien erzeuge.
Wenn ich die Vorlage Datei öffne wird ja automatische eine XLS Datei mit 1 als Namensendung generiert.
Ziel:
Über ein Makro möchte ich diese Datei mit einem Namen bestehend aus Zelle H1 und Zelle L1 im gleichen Ordner speichern in der auch die Vorlagedatei ist. Danach soll die Vorlagedatei wieder geöffnet werden.
Das Speichern unter dem gewünschten Namen funktioniert schon, nur nicht in dem Ordner in der die Vorlagedatei ist.
Auch ist das Öffnen der Vorlagedatei nach dem Speichern noch nicht integriert.
Kann mir hierbei jemand helfen?
Hier die Datei (müsste dann als Vorlagedatei abgespeichert werden)
https://www.herber.de/bbs/user/141881.xlsx
Viele Grüße Ulli

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Sub SaveSpezial() Dim sPath$, sName$, sSaveFullName$ With ThisWorkbook sPath = Left$(.FullName, InStrRev(.FullName, "\")) sName = Right$(.FullName, Len(.FullName) - InStrRev(.FullName, "\")) End With 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

Private Sub Workbook_AfterSave(ByVal Success As Boolean) Dim CP As Object If LCase(ThisWorkbook.FullName) Like "*.xlt?" Or LCase(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

Beliebteste Forumthreads (12 Monate)

Datei im gleichen Ordner speichern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datei im gleichen Ordner speichern

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread