VBA: Speichern unter mit vorgegebenem Namen

igPfad = ThisWorkbook.Path & "\Export\" 'Speichern Worksheets(Array(BlattName, "Muster")).Copy With ActiveWorkbook .Sheets("Muster").Visible = True .SaveAs .SaveAs igPfad & BlattName & ".xls", 52 .Close 0 .Sheets("Muster").Visible = False End With

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub PfadAuswahlDialog() Dim SuchDialog As FileDialog Dim Pfad As String Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker) With SuchDialog .Title = "Bitte Verzeichnis wählen" .AllowMultiSelect = False If .Show -1 Then MsgBox "Datei wurde nicht gespeichert!", vbInformation Exit Sub Else: Pfad = .SelectedItems(1) & "\" End If End With ThisWorkbook.SaveAs Pfad & BlattName & ".xls", 52 End Sub

Private Sub CommandButton3_Click() On Error GoTo Fertig 'Deklaration der Variablen Dim BlattName As String Dim igPfad As String Dim BlattDa As Boolean 'Blattname festlegen BlattName = ActiveCell.Value If BlattName = "" Then Exit Sub 'Ordnerpfad für Export bestimmen igPfad = ThisWorkbook.Path & "\Export\" 'Aktive Zelle prüfen If ActiveCell.Column 2 Or ActiveCell.Row

Private Sub CommandButton3_Click() On Error GoTo Fertig 'Deklaration der Variablen Dim BlattName As String Dim igPfad As String Dim BlattDa As Boolean Dim SuchDialog As FileDialog 'Blattname festlegen BlattName = ActiveCell.Value If BlattName = "" Then Exit Sub 'Ordnerpfad für Export bestimmen Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker) With SuchDialog .Title = "Bitte Verzeichnis wählen" .AllowMultiSelect = False If .Show -1 Then MsgBox "Datei wurde nicht gespeichert!", vbInformation Exit Sub Else: igPfad = .SelectedItems(1) & "\" End If End With 'Aktive Zelle prüfen If ActiveCell.Column 2 Or ActiveCell.Row

Private Sub CommandButton3_Click() On Error GoTo Fertig 'Deklaration der Variablen Dim BlattName As String Dim igPfad As String Dim BlattDa As Boolean Dim SuchDialog As FileDialog Dim Blatt As Worksheet 'Blattname festlegen BlattName = ActiveCell.Value If BlattName = "" Then Exit Sub 'Aktive Zelle prüfen If ActiveCell.Column 2 Or ActiveCell.Row .InitialFileName = ThisWorkbook.Path If .Show -1 Then MsgBox "Datei wurde nicht gespeichert!", vbInformation Exit Sub Else: igPfad = .SelectedItems(1) & "\" End If End With 'Speichern Worksheets(Array(BlattName, "Beispiel")).Copy With ActiveWorkbook .Sheets("Beispiel").Visible = True .SaveAs igPfad & BlattName & ".xls", 52 .Close 0 .Sheets("Beispiel").Visible = False End With Else MsgBox "Blatt mit dem Namen " & BlattName & " ist nicht vorhanden!" & _ "Bitte zuerst das Blatt erstellen!" Selection.Hyperlinks.Delete ActiveCell.BorderAround ColorIndex:=5, Weight:=xlThin With Selection.Font .Name = "Arial" .Size = 10 .ColorIndex = xlAutomatic .Underline = xlUnderlineStyleNone End With Exit Sub End If Fertig: End Sub

Private Sub CommandButton3_Click() 'Deklaration der Variablen Dim BlattName As String Dim igPfad As String Dim BlattDa As Boolean Dim SuchDialog As FileDialog Dim Blatt As Worksheet 'Blattname festlegen BlattName = ActiveCell.Value If BlattName = "" Then Exit Sub 'Aktive Zelle prüfen If ActiveCell.Column 2 Or ActiveCell.Row -1 Then MsgBox "Datei wurde nicht gespeichert!", vbInformation Exit Sub Else: igPfad = .SelectedItems(1) & "\" End If End With 'Speichern Worksheets(Array(BlattName, "Beispiel")).Copy With ActiveWorkbook .Worksheets("Beispiel").Visible = False .SaveAs igPfad & BlattName, 52 .Close End With Else MsgBox "Blatt mit dem Namen " & BlattName & " ist nicht vorhanden!" & _ "Bitte zuerst das Blatt erstellen!" Selection.Hyperlinks.Delete ActiveCell.BorderAround ColorIndex:=5, Weight:=xlThin With Selection.Font .Name = "Arial" .Size = 10 .ColorIndex = xlAutomatic .Underline = xlUnderlineStyleNone End With Exit Sub End If End Sub

Private Sub CommandButton3_Click() Dim DieseMappe As Workbook Dim ZielMappe As Workbook Dim ExportBlatt As String Dim DateiName As String Dim Pfad As String Dim PfadDialog As FileDialog Application.ScreenUpdating = False Set DieseMappe = ThisWorkbook With ActiveCell If .Value = vbNullString Then Exit Sub If .Column 2 Or .Row -1 Then MsgBox "Vorgang abgebrochen", vbInformation Exit Sub Else: Pfad = .SelectedItems(1) End If End With If Not Right(Pfad, 1) = "\" Then Pfad = Pfad & "\" DateiName = Replace(ExportBlatt, ".", "_") With ZielMappe .Worksheets("Muster").Visible = xlSheetHidden .SaveAs Filename:=Pfad & DateiName, FileFormat:=51 .Close savechanges:=True End With Set DieseMappe = Nothing Set ZielMappe = Nothing Set PfadDialog = Nothing Application.ScreenUpdating = True End Sub Function BlattExistiert(Wb As Workbook, Blatt As String) As Boolean 'Wahr, wenn ein Tabellenblatt mit Namen = Blatt in der Mappe vorhanden ist Dim Ws As Worksheet BlattExistiert = False For Each Ws In Wb.Worksheets If Ws.Name = Blatt Then BlattExistiert = True Exit Function End If Next Ws End Function

Hallo Michael,
da hast du durchaus recht.... Ich werde meinen Code mal aufräumen und auch mal teilweise ausmisten... Danke dir für den Code, der passt soweit gut, mir ist nur eine Sache noch aufgefallen:
Beim ersten Export-Abruch läuft es super. Dann kommt die Mitteilung, dass es nicht exportiert wurde. Wenn ich aber ein zweites mal exportiere (ich bestätige den Ort, wo er es ablegen soll, dort liegt aber nun schon eine Datei mit gleichem Namen) und den Ablegeort bestätige erscheint die Meldung dass dort schon eine Datei mit dem gleichen Namen liegt. Bis hierhin alles gut. Ich kann mich dann entscheiden, die Datei zu überschreiben (Auswahl "ja", "nein", "Abbrechen"). Wenn ich es tue funktioniert es auch, sobald ich aber "nein" oder "Abbrechen" wähle kommt ein Laufzeitfehler 1004: Die Methode 'SaveAs' für das Objekt '_Workbook' ist fehlgeschlagen. Im Debugger hält er dann bei


With ZielMappe
.SaveAs Filename:=Pfad & DateiName, FileFormat:=51
.Close savechanges:=True
End With

an. Vorher war das glaube ich über die Funktion OnError und der Sprungmarke, dass er die Funktion dann einfach beendet hat. Was müsste ich denn noch einfügen, damit er in dem geschilderten Fall dann nicht mehr hängen bleibt (könnte ja einfach melden, dass die Datei nicht gespeichert wurde und beendet es damit)?
Lg Michael

Hallo Michael!
Hier nochmal der gesamte, überarbeitete Code für Deinen CommandButton3. Hab folgendes ergänzt: Es wird beim Speichern der Export-Datei geprüft, ob diese am gewählten Ort schon vorhanden ist; wenn nicht wird gespeichert wie bisher, wenn schon, erhält der Benutzer die Möglichkeit bewusst zu überschreiben oder aber abzubrechen.

Private Sub CommandButton3_Click()
Dim DieseMappe As Workbook
Dim ZielMappe As Workbook
Dim ExportBlatt As String
Dim DateiName As String
Dim Pfad As String
Dim PfadDialog As FileDialog
Dim Ersetzen As Variant
Application.ScreenUpdating = False
Set DieseMappe = ThisWorkbook
With ActiveCell
If .Value = vbNullString Then Exit Sub
If .Column  2 Or .Row  -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1)
End If
End With
If Not Right(Pfad, 1) = "\" Then Pfad = Pfad & "\"
DateiName = Replace(ExportBlatt, ".", "_")
If Not Dir(Pfad & DateiName & ".xls*", vbDirectory) = vbNullString Then
Ersetzen = MsgBox("Datei bereits vorhanden! Überschreiben?", _
vbOKCancel, "Datei ersetzen?")
Select Case Ersetzen
Case Is = vbOK
With ZielMappe
Application.DisplayAlerts = False
.Worksheets("Muster").Visible = xlSheetHidden
.SaveAs Filename:=Pfad & DateiName, FileFormat:=51
.Close savechanges:=True
End With
Case Is = vbCancel
MsgBox "Abbruch! Datei wird nicht gespeichert!", vbInformation, "Abbruch"
ZielMappe.Close savechanges:=False
End Select
Else:
With ZielMappe
.Worksheets("Muster").Visible = xlSheetHidden
.SaveAs Filename:=Pfad & DateiName, FileFormat:=51
.Close savechanges:=True
End With
End If
Set DieseMappe = Nothing
Set ZielMappe = Nothing
Set PfadDialog = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function BlattExistiert(Wb As Workbook, Blatt As String) As Boolean
'Wahr, wenn ein Tabellenblatt mit Namen = Blatt in der Mappe vorhanden ist
Dim Ws As Worksheet
BlattExistiert = False
For Each Ws In Wb.Worksheets
If Ws.Name = Blatt Then
BlattExistiert = True
Exit Function
End If
Next Ws
End Function

LG
Michael

Beliebteste Forumthreads (12 Monate)

VBA: Speichern unter mit vorgegebenem Namen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Speichern unter mit vorgegebenem Namen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread