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

VBA - Speichern unter + Pfad + Dateiendung

VBA - Speichern unter + Pfad + Dateiendung
08.11.2017 15:40:31
Daniel
Hallo,
ich brauche bitte Hilfe.
Da ich mich in VBA nicht so perfekt aufkenne habe ich mir eine Formel zusammenkopiert welche aber leider nicht ganz so funktioniert wie ich das gerne hätte.
Bzw funktioniert eigentlich Tadellos, nur speichert die Datei leider nicht obwohl sogar der Speichern unter Dialog aufgerufen wird wie gewünscht.
Kann mir jemand sagen wieso die Datei nicht gespeichert wird?
Ziel ist einfach die Datei in dem Format .xlsm an dem oben angeführten Pfad speichern bzw. das speichern unter fenster aufzurufen.
Und wenn ich schon dabei bin brauch ich das Makro 1x für Tabellenblat 1 und 1x für Tabellenblatt 1u.2
Danke

Sub Speichern_unter()
Dim Pfad$, Datei$, Filter$, Endg$, File
Pfad = Environ("UserProfile") & "\Oras Group\Projects AUT - Documents\ANGEBOTE\"
Datei = ActiveSheet.Range("Q10")
If Datei = "" Then
MsgBox "Erst Angebotsnummer vergeben!"
Exit Sub
End If
Endg = ".xlsm"
If InStr(Datei, Endg) = 0 Then 'Prüfung ob Zelle bereits Endung enthält
Datei = Datei & Endg
End If
Filter = "Excel Files (*" & Endg & "), *" & Endg
File = Application.GetSaveAsFilename(Pfad & Datei, Filter)
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Speichern unter + Pfad + Dateiendung
13.11.2017 11:49:55
fcs
Hallo Daniel,
mit deinem Makro wählst du nur den Dateinamen aus.
Du muss noch die Datei unter dem ausgewählten Namen speichern.
Wenn du einzelne oder mehrere Blätter der Mappe in einer Datei speichern willst, dann musst du das Blatt/die Blätter erst in eine neue Datei kopieren.
Nachfolgend zwei Varianten
A) Auswahl Name unter dem gespeichert werden soll
B) Anzeige des "Speichern unter"-Dialogs
Gruß
Franz
Sub Speichern_unter()
'mit Dateinamen-Auswahl-Dialog
Dim Pfad$, Datei$, Filter$, Endg$, File
Dim wkb As Workbook, wkbNeu As Workbook
Set wkb = ActiveWorkbook
Pfad = Environ("UserProfile") & "\Oras Group\Projects AUT - Documents\ANGEBOTE\"
Pfad = Environ("UserProfile") & "\Documents\Archiv\"
Datei = ActiveSheet.Range("Q10")
If Datei = "" Then
MsgBox "Erst Angebotsnummer vergeben!"
Exit Sub
End If
Endg = ".xlsm"
If InStr(Datei, Endg) = 0 Then 'Prüfung ob Zelle bereits Endung enthält
Datei = Datei & Endg
End If
Filter = "Excel Files (*" & Endg & "), *" & Endg
File = Application.GetSaveAsFilename(Pfad & Datei, Filter)
If File = False Then Exit Sub
wkb.Worksheets(1).Copy 'Statt Indexnummer kann auch der Blattname in _
Anführungszeichen angegeben werden
Set wkbNeu = ActiveWorkbook
wkbNeu.SaveAs Filename:=Replace(File, Endg, "_1" & Endg), FileFormat:=52
wkbNeu.Close savechanges:=False
wkb.Worksheets(Array(1, 2)).Copy 'Statt Indexnummern können auch die Blattnamen in _
Anführungszeichen angegeben werden
Set wkbNeu = ActiveWorkbook
wkbNeu.SaveAs Filename:=Replace(File, Endg, "_1u2" & Endg), FileFormat:=52
wkbNeu.Close savechanges:=False
End Sub
Sub Speichern_unter_Dialog()
'mit Datei-Speichern unter-Dialog
Dim Pfad$, Datei$, Filter$, Endg$, File, varDialog
Dim wkb As Workbook, wkbNeu As Workbook
Set wkb = ActiveWorkbook
Pfad = Environ("UserProfile") & "\Oras Group\Projects AUT - Documents\ANGEBOTE\"
Pfad = Environ("UserProfile") & "\Documents\Archiv\"
Datei = ActiveSheet.Range("Q10")
If Datei = "" Then
MsgBox "Erst Angebotsnummer vergeben!"
Exit Sub
End If
Endg = ".xlsm"
If InStr(Datei, Endg) = 0 Then 'Prüfung ob Zelle bereits Endung enthält
Datei = Datei & Endg
End If
File = Pfad & Datei
wkb.Worksheets(1).Copy 'Statt Indexnummer kann auch der Blattname in _
Anführungszeichen angegeben werden
Set wkbNeu = ActiveWorkbook
varDialog = Application.Dialogs(xlDialogSaveAs).Show( _
Replace(File, Endg, "_1" & Endg), 52)
wkbNeu.Close savechanges:=False
wkb.Worksheets(Array(1, 2)).Copy 'Statt Indexnummern können auch die Blattnamen in _
Anführungszeichen angegeben werden
Set wkbNeu = ActiveWorkbook
varDialog = Application.Dialogs(xlDialogSaveAs).Show( _
Replace(File, Endg, "_1u2" & Endg), 52)
wkbNeu.Close savechanges:=False
End Sub

Anzeige

123 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige