VBA - Speichern unter + Pfad + Dateiendung

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

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

VBA - Speichern unter + Pfad + Dateiendung

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

339 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Speichern unter + Pfad + Dateiendung

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

339 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread