Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

xltm bei "Speichern" als xlsm, Dateiname & Ort

xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 11:16:52
Marcel
Hallo zusammen,
ich habe eine xltm Datei und möchte, dass beim Klick auf "Speichern" sich das Fenster "Speichern unter" öffnet und gleich Speicherort und Dateiname vorgegeben wird.
Herausforderung dabei: Der Dateiname soll sich aus zwei Zellen eines bestimmten Arbeitsblatts der Excel ziehen und dabei einen Unterstrich als Trennung erhalten (Zelle 1=Artikelnummer, Zelle 2=Artikelname).
Kann hier jemand helfen?
Danke und Grüße
Marcel

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 12:51:27
Uwe
Hallo Marcel,
teste mal so (Code kommt in das schon vorhandene VBA-Modul "DieseArbeitsmappe"):

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename(Worksheets("Blatt2").Range("B2").Value & _
Worksheets("Blatt4").Range("C3").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 13:36:48
Marcel
Hi Uwe,
auch bei Deiner Lösung: Erstmal Danke.
Klappt an sich gut. Der Unterstrich zwischen den beiden Zellen aus denen er sich den Dateinamen zieht fehlt nur. Wie bekomme ich den nich dazwischen.
Dann noch die Frage: Wo kann ich den fixen Speicherort angeben?
Und zu guter letzt: Die Artikelnummer besteht aus 10 Zeichen (erster Teil des Dateinamens) und sollte beim Speichern wie folgt mit Punkten ausgegeben werden: XX.XXXX.XXXX (Herausforderung: manchmal wenn nur 9 Zeichen in der Zelle stehen soll eine Null vorangestellt werden: 0X.XXXX.XXXX).
Danke für die Hilfe und Grüße
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 12:52:47
ChrisL
Hi Marcel
Alt + F11, links Doppelklick auf DIESEARBEITSMAPPE, Code einfügen...
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sDateiName As String
sDateiName = ThisWorkbook.Worksheets("Tabelle1").Range("A1") & "_" & ThisWorkbook.Worksheets(" _
Tabelle1").Range("B1") 'hier anpassen
On Error Resume Next
Application.EnableEvents = False
Cancel = True
If SaveAsUI Then
Application.Dialogs(xlDialogSaveAs).Show (sDateiName), xlOpenXMLWorkbookMacroEnabled
Else
ThisWorkbook.Save
End If
ThisWorkbook.Saved = True
Application.EnableEvents = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Saved = False Then
Select Case MsgBox("Sollen Ihre Änderungen in '" & ThisWorkbook.Name & "' gespeichert  _
werden?", vbYesNoCancel + vbExclamation)
Case vbYes
On Error Resume Next
Application.EnableEvents = False
If LCase(Right(ThisWorkbook.Name, 4))  "xlsm" Then
Dim sDateiName As String
sDateiName = ThisWorkbook.Worksheets("Tabelle1").Range("A1") & ", " & ThisWorkbook. _
Worksheets("Tabelle1").Range("B1") 'hier anpassen
Application.Dialogs(xlDialogSaveAs).Show (sDateiName),  _
xlOpenXMLWorkbookMacroEnabled
Else
ThisWorkbook.Save
End If
Application.EnableEvents = True
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
End Select
End If
End Sub

cu
Chris
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 12:55:54
ChrisL
ein paar Strings wurden getrennt, darum nochmal...
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sDateiName As String
sDateiName = ThisWorkbook.Worksheets("Tabelle1").Range("A1") & "_" & _
ThisWorkbook.Worksheets("Tabelle1").Range("B1") 'hier anpassen
On Error Resume Next
Application.EnableEvents = False
Cancel = True
If SaveAsUI Then
Application.Dialogs(xlDialogSaveAs).Show (sDateiName), xlOpenXMLWorkbookMacroEnabled
Else
ThisWorkbook.Save
End If
ThisWorkbook.Saved = True
Application.EnableEvents = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Saved = False Then
Select Case MsgBox("Sollen Ihre Änderungen in '" & ThisWorkbook.Name & _
"' gespeichert werden?", vbYesNoCancel + vbExclamation)
Case vbYes
On Error Resume Next
Application.EnableEvents = False
If LCase(Right(ThisWorkbook.Name, 4))  "xlsm" Then
Dim sDateiName As String
sDateiName = ThisWorkbook.Worksheets("Tabelle1").Range("A1") & "_" & _
ThisWorkbook.Worksheets("Tabelle1").Range("B1") 'hier anpassen
Application.Dialogs(xlDialogSaveAs).Show (sDateiName), _
xlOpenXMLWorkbookMacroEnabled
Else
ThisWorkbook.Save
End If
Application.EnableEvents = True
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
End Select
End If
End Sub

Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 13:22:43
Marcel
Vielen Dank für eure Hilfe.
Muss ich beide Codes von Dir Chris übernehmen? Gebe ich dort wo "Tabelle1" steht den Namen des Arbeitsblatts ein oder lasse ich Tabelle1 stehen wenn es auch Tabelle1 in Visual Basic ist?
Außerdem, wo kann ich den festen Speicherort angeben?
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 16:34:59
ChrisL
Hi Marcel
Tabelle1, A1, B1 musst du anpassen.
Und hier noch mit Default-Pfad:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sDateiName As String
Const sDefaultPfad As String = "C:\Pfad\"
sDateiName = sDefaultPfad & ThisWorkbook.Worksheets("Tabelle1").Range("A1") & "_" & _
ThisWorkbook.Worksheets("Tabelle1").Range("B1") 'hier anpassen
On Error Resume Next
Application.EnableEvents = False
Cancel = True
If SaveAsUI Then
Application.Dialogs(xlDialogSaveAs).Show (sDateiName), xlOpenXMLWorkbookMacroEnabled
Else
ThisWorkbook.Save
End If
ThisWorkbook.Saved = True
Application.EnableEvents = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Saved = False Then
Select Case MsgBox("Sollen Ihre Änderungen in '" & ThisWorkbook.Name & _
"' gespeichert werden?", vbYesNoCancel + vbExclamation)
Case vbYes
On Error Resume Next
Application.EnableEvents = False
If LCase(Right(ThisWorkbook.Name, 4))  "xlsm" Then
Dim sDateiName As String
Const sDefaultPfad As String = "C:\Pfad\"
sDateiName = sDefaultPfad & ThisWorkbook.Worksheets("Tabelle1").Range("A1") & "_" & _
ThisWorkbook.Worksheets("Tabelle1").Range("B1") 'hier anpassen
Application.Dialogs(xlDialogSaveAs).Show (sDateiName), _
xlOpenXMLWorkbookMacroEnabled
Else
ThisWorkbook.Save
End If
Application.EnableEvents = True
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
End Select
End If
End Sub

Damit der Prozess auch beim Schliessen mittels Kreuz rechts oben funktioniert, braucht es m.E. ein Before_Close Ereignis.
cu
Chris
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 13:30:56
Uwe
Hallo Marcel,
ich hatte das mit dem fixen Speicherort ganz vergessen.
Jetzt ist er mit drin und auch der Unterstrich.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename("C:\Ablageordner\" & _
Worksheets("Blatt2").Range("B2").Value & "_" & _
Worksheets("Blatt4").Range("C3").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 13:44:59
Marcel
Hi Uwe,
danke! Ich habe gesehen, Du hast auch den Unterstrich noch eingefügt - top!
Eine Frage noch:
Die Artikelnummer besteht aus 10 Zeichen (erster Teil des Dateinamens) und sollte beim Speichern wie folgt mit Punkten ausgegeben werden: XX.XXXX.XXXX (Herausforderung: manchmal wenn nur 9 Zeichen in der Zelle stehen soll eine Null vorangestellt werden: 0X.XXXX.XXXX).
Danke für die Hilfe und Grüße
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 13:56:51
Uwe
Hallo Marcel,
teste mal damit:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"C:\Ablageordner\" & _
Format(Worksheets("Blatt2").Range("B2").Value, "00\.0000\.0000_") & _
Worksheets("Blatt4").Range("C3").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe
Anzeige
AW: xltm bei "Speichern" als xlsm, Dateiname & Ort
10.10.2016 14:07:10
Marcel
Hi Uwe,
danke für die schnelle Antwort.
Das mit der Formatierung funktioniert leider nicht. Wo zuvor der richtige Dateiname im Dateinamenfeld drin stand steht jetzt gar nichts mehr.
Danke und Grüße
Marcel
Da bist Du gefragt
10.10.2016 15:16:26
Uwe
Hallo Marcel,
Wo zuvor der richtige Dateiname im Dateinamenfeld drin stand steht jetzt gar nichts mehr.
am Code liegt das mit Sicherheit nicht.
Gruß Uwe
AW: Da bist Du gefragt
10.10.2016 15:53:28
Marcel
Hi Uwe,
bist Du Dir sicher?
In dem letzten Code den Du gepostet hast war auch der Unterstrich dazwischen wieder raus. Kann es evtl. sein, dass beim Kopieren was verloren gegangen ist? Ich hab´s mehrfach mit der Formatierung probiert aber immer das gleiche: Mit Formatierung leeres Dateinamenfeld, ohne Formatierung steht Dateiname da.
Danke und Grüße
MArcel
Anzeige
Code noch einmal
10.10.2016 15:58:01
Uwe
Hallo Marcel,
bei mir geht es damit:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"C:\Ablageordner\" & _
Format(Worksheets("Blatt2").Range("B2").Value, "00\.0000\.0000_") & _
Worksheets("Blatt4").Range("C3").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe
Anzeige
AW: Code noch einmal
10.10.2016 16:59:55
Marcel
Mhhh, das ist echt seltsam.
Ich habe den Code wie folgt auf meine Datei angepasst:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"\\xxx-root-xxx\" & _
Format(Worksheets("Artikelsteckbrief").Range("L12").Value, "00\.0000\.0000_") &  _
"_" & _
Worksheets("Artikelsteckbrief").Range("L14").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Hiermit funktioniert es nicht.
Nehme ich die beiden Teile heraus: Format(..., "00\.0000\.0000_") funktioniert es, d.h. Wert aus Zelle L12 (leider ohne vorangestellte 0 bei nur 9 Ziffern) + Unterstrich + Wert aus Zelle L14 + .xlsm
Das ist dann der funktionierende Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"\\xxx-root-xxx\" & _
Worksheets("Artikelsteckbrief").Range("L12").Value & "_" & _
Worksheets("Artikelsteckbrief").Range("L14").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Liegt es evtl. an meiner Excel Version MS Office 2013 mit Windows 10 Betriebssystem?
Grüße
Marcel
Vorschlag
10.10.2016 20:10:25
Uwe
Hallo Marcel,
vielleicht verträgt sich euer Netzwerk nicht mit mehreren Punkten im Dateinamen. Ich würde das eh nicht machen.
Probiere mal mit Unterstrichen anstatt Punkten.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"\\xxx-root-xxx\" & _
Format(Worksheets("Artikelsteckbrief").Range("L12").Value, "00\_0000\_0000_") &  _
_
Worksheets("Artikelsteckbrief").Range("L14").Value, _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe
AW: Vorschlag
11.10.2016 08:41:30
Marcel
Guten Morgen Uwe,
vielen Dank, daran lag es tatsächlich!
So, dann in diesem Zusammenhang noch eine Frage: Ich habe gelernt, dass man Leerzeichen, Umlaute, Sonderzeichen, Punkte etc. in einem Dateinamen vermeiden sollte. In Zelle L14 enthält der Text genau das. Gibt es eine Möglichkeit dies für den Dateinamen "umzuwandeln"?
Danke und Grüße
Marcel
AW: Vorschlag
11.10.2016 10:01:40
Marcel
Ergänzung:
Mit Umwandlung meine ich:
a) Umlaute: ae, oe, ue Schreibweise
b) Leerzeichen: werden zum Unterstrich
c) ß: zu ss
d) Sonderzeichen: Unterstrich
e) und dann noch: wenn mehrere Unterstriche dadurch hintereinander stehen so umwandeln, dass nur ein Unterstrich da steht
Wird immer größer die Herausforderung... :-|
Danke für Deine Unterstützung!
AW: Vorschlag
12.10.2016 08:44:38
Uwe
Hallo Marcel,
in ein allgemeines Modul kommen die beiden Funktionen:

Public Function TextSaeubern(ByVal strT As String) As String
Const strS As String = "-.,:;#+'*?=)(/&%$§!~\}][{"
Dim i As Long
strT = Replace(strT, "ä", "ae")
strT = Replace(strT, "ö", "oe")
strT = Replace(strT, "ü", "ue")
strT = Replace(strT, "ß", "ss")
strT = Replace(strT, "Ä", "Ae")
strT = Replace(strT, "Ö", "Oe")
strT = Replace(strT, "Ü", "Ue")
strT = Replace(strT, " ", "_")
For i = 1 To Len(strS)
strT = Replace(strT, Mid(strS, i, 1), "_")
Next i
TextSaeubern = StripDuplicates(strT, "_")
'Mit Umwandlung meine ich:
'a) Umlaute: ae, oe, ue Schreibweise
'b) Leerzeichen: werden zum Unterstrich
'c) ß: zu ss
'd) Sonderzeichen: Unterstrich
'e) und dann noch: wenn mehrere Unterstriche dadurch hintereinander stehen so umwandeln, dass  _
nur ein Unterstrich da steht
End Function
Public Function StripDuplicates(ByVal strZ As String, _
Optional ByVal sChar As String = " ") As String
' Entfernt mehrfach vorkommende Zeichen(-ketten) aus einem String
' http://www.vbarchiv.net/tipps/tipp_2215-doppelte-zeichen-aus-einem-string-entfernen.html
If strZ = String$(Len(strZ), sChar) Then
strZ = sChar
Else
While Len(strZ) > 0 And InStr(1, strZ, sChar & sChar) > 0
strZ = Replace(strZ, sChar & sChar, sChar)
Wend
End If
StripDuplicates = strZ
End Function
Im Modul "DieseArbeitsmappe" dann

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"\\xxx-root-xxx\" & _
Format(Worksheets("Artikelsteckbrief").Range("L12").Value, "00\_0000\_0000_") &  _
_
TextSaeubern(CStr(Worksheets("Artikelsteckbrief").Range("L14").Value)), _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe
AW: Vorschlag
12.10.2016 17:52:44
Marcel
Hallo Uwe,
vielen herzlichen Dank!!! Es funktioniert alles genau so, wie ich es mir vorstelle! Das ist bzw. Du warst eine enorme Hilfe.
Zum Abschluss noch eine Frage: Hast Du Tipps (Webseiten, Tutorials, Bücher, Kurse, ...), wie ich VBA am besten lernen kann damit ich zukünftig nicht mehr so häufig auf Hilfe angewiesen bin?
Viele Grüße
Marcel

331 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige