Office: (Office 2013) über Button speichern ohne weitere Abfrage

Hallo Mitstreiter

Ich habe folgendes kleine Makro probiert,

Private Sub CommandButton1_Click()
Dim i As Long
With ThisWorkbook.ActiveSheet
pfad = .Range("B3")
Datei = .Range("B2")
ActiveWorkbook.SaveAs Filename:=pfad & Datei & ".xlsm"
End With
End Sub

Es soll mir generierte Verzeichnis aus der Zelle "B3" (wenn noch nicht vorhanden) anlegen und dann die Datei in dem aus "B2" generierten Dateinamen anlegen, bzw. überschreiben. Wenn möglich auch ohne irgendwelche Abfragen, wie z.B. "Datei überschreiben?".

Ich bekomme aber nur die Fehlermeldung " Die Methode 'SaveAs' für das Opjekt _Workbook' ist fehlgeschlagen.

Ich würde mich freuen, wenn ihr mir hier weiter helfen könnt.

Gruß
Andreas

 

Hallo Andreas,

das ist zwar möglich, doch geschieht dies nicht automatisch bei der Verwendung der ".SaveAs"-Methode des Workbook-Objektes.

Meine Makrozusätze zu deiner Vorgabe gehen davon aus, dass in der Zelle B3 bzw. B2 ein gültiger/sinnvoller Pfad und Dateiname enthalten ist.
Die Pfad-Variable wird überprüft - falls sie nicht leer ist -, ob ein abschließender "\" vorhanden ist.
Ist der Pfad noch nicht vorhanden, käme es in der Zeile ".SaveAs...." zu einem Fehler, der aber durch das davor stehende "On Error..." abgefangen wird, sodass in diesem Fall ein Sprung zur Programmmarke "Err_Verzeichnis:" erfolgt.

Dort wird mit der "MkDir..."-Anweisung dieses Verzeichnis tatsächlich angelegt. Mit der nachfolgenden "Resume"-Anweisung wird der Error-Modus beendet und erfolgt wieder ein Rücksprung zur ursprünglichen Fehlerquelle, also zur Zeile ".SaveAs...", die aber jetzt inzwischen fehlerfrei ausführbar sein sollte.

Code:

Private Sub CommandButton1_Click()
  Dim Pfad As String, Datei As String
  
  With ThisWorkbook
    With .ActiveSheet
      Pfad = .Range("B3")
      Datei = .Range("B2")
    End With
    If Len(Pfad) Then If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
    On Error GoTo Err_Verzeichnis
    .SaveAs Filename:=Pfad & Datei & ".xlsm"
  End With
  Exit Sub
  
Err_Verzeichnis:
  MkDir Path:=Pfad
  Resume
  
End Sub

 

Hallo Anton Exl,

erst mal danke für deine Unterstützung.

Ich habe dein Makro übernommen, aber es zeigt mir einen Debugg bei "§MkDir Path:=Pfad" an.

Das Makro braucht auch nicht selbst nach einer Alternative suchen, da ich das schon mit einer kleinen Wenn-Abfrage über eine Formel gelöst habe.

Danke dir schon mal für deine Mühe

Andreas

 

Hallo Andreas,

wäre schön gewesen, wenn du mir die Fehlernummer/Fehlermeldung an dieser Stelle mitgeteilt hättest. Meine Vermutung ist jedoch, dass an dieser Stelle der abschließende Backslash, der zu diesem Zeitpunkt in der Variablen "Pfad" enthalten ist, entfernt gehört:

Code:

Private Sub CommandButton1_Click()
  Dim Pfad As String, Datei As String
  
  With ThisWorkbook
    With .ActiveSheet
      Pfad = .Range("B3")
      Datei = .Range("B2")
    End With
    If Len(Pfad) Then If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
    On Error GoTo Err_Verzeichnis
    .SaveAs Filename:=Pfad & Datei & ".xlsm"
  End With
  Exit Sub
  
Err_Verzeichnis:
  MkDir Path:=[COLOR="#0000CD"]Left(Pfad,Len(Pfad)-1)[/COLOR]
  Resume
  
End Sub

 

Hallo Anton,

erst mal sorry, bin recht neu bei euch. Nächstes mal schreib ich die Fehlermeldung natürlich mit rein.

Soweit läuft es jetzt. Danke dafür.

Ich habe das Makro jetzt noch insoweit ergänzt, dass nicht mehr die Abfrage kommt, ob es eine ggf. vorhandene Datei überschreiben darf oder nicht.

Private Sub CommandButton1_Click()
Dim Pfad As String, Datei As String

With ThisWorkbook
With .ActiveSheet
Pfad = .Range("B3")
Datei = .Range("B1")
End With
If Len(Pfad) Then If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
On Error GoTo Err_Verzeichnis
Application.DisplayAlerts = False
.SaveAs Filename:=Pfad & Datei & ".xlsm"
Application.DisplayAlerts = True
End With
Exit Sub

Err_Verzeichnis:
MkDir Path:=Left(Pfad, Len(Pfad) - 1)
Resume

End Sub

Jetzt habe ich ein weiteres Problem Das Makro schreibt die Verzeichnisse nicht selbst, wenn sie noch nicht vorhanden sind. Wobei dann natürlich die Fehlermeldung "Verzeichnis nicht gefunden" kommt. Gibt es die Möglichkeit, dass Excel sich ggf. das gewünschte Verzeichnis selbst anlegt?

Wäre toll wenn du mir hier auch noch mal unter die Arme greifen könntest

Gruß
Andreas

 

Hallo Andreas,

das ist leider eine irreführende Fehlermeldung !!!

Wenn du zB. händisch eine Excel-Mappe, die ein Makro enthält, mit dem "Speichern unter"-Dateidialog speicherst, musst du
1) zuerst die Combobox für den Dateityp auf "*.xlsm" stellen und
2) dann kannst du die Excel-Datei als "...Datei.xlsm" speichern.
Das Gleiche musst du auch tun, wenn du per Makro die Excel-Mappe speichern willst - nur wird hier Punkt 1) über den rot gekennzeichneten Parameter der SaveAs-Methode des Workbook-Objektes erledigt.

Die MkDir-Anweisung erzeugt tatsächlich ein Verzeichnis (falls es noch nicht existiert). Existiert es jedoch bereits, erhält man eine Fehlermeldung bei dem Versuch, es noch einmal zu erzeugen. Das ist der Grund, warum ich das Ganze über "On Error GoTo ..." programmiert habe.

Code:

Public Sub CommandButton1_Click()
   Dim Pfad As String, Datei As String
  
   With ThisWorkbook
     With .ActiveSheet
        Pfad = .Range("B3")
        Datei = .Range("B1")
     End With
     If Len(Pfad) Then If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
     On Error GoTo Err_Verzeichnis
     Application.DisplayAlerts = False
     .SaveAs Filename:=Pfad & Datei & ".xlsm"[COLOR="#FF0000"], FileFormat:=xlOpenXMLWorkbookMacroEnabled[/COLOR]
     Application.DisplayAlerts = True
   End With
   Exit Sub
  
Err_Verzeichnis:
   MkDir Path:=Left(Pfad, Len(Pfad) - 1)
   Resume

 End Sub

 

Hallo Anton,

Irgendwie läuft es noch nicht so richtig rund

Wollte die Datei eigentlich hochladen, aber mit etwas über 600 kb ist die Datei hier leider zu groß

Also versuche ich es in Worte zu fassen ;-)

Über ein Textfeld soll der Benutzer angeben, wie der Pfad heißen soll, in dem die Dateien zukünftig abgelegt werden sollen. Z.B. "N:\Allgemein\Test"

Daraus wird über eine Formel dann der Pfad um die Jahreszahl und dem Monat ergänzt z.B. "N:\Allgemein\Test\2015\11"

Er zeigt mir weiterhin an, dass er den Pfad nicht gefunden hat und "Laufzeitfehler 76" Im Makro selbst wird die Zeile "MkDir Path:=Left(Pfad, Len(Pfad) - 1)" Gelb hinterlegt.

Gruß
Andreas

 

Hallo Andreas,

eines muss dir klar sein: Wenn du beliebige Pfade einsetzt, musst du zuerst dafür sorgen, dass die dazu gehörige Verzeichnis-Hierarchie existiert. Du kannst nicht ein Verzeichnis mit "MkDir" erzeugen, wenn sein Eltern-Verzeichnis noch gar nicht existiert.
Aus diesem Grund habe ich dir jetzt ein Unterprogramm in Form einer Funktion, die diese Test- und Erzeugungsaufgaben erledigt, hinzugefügt.

Code:

Option Explicit

Public Sub CommandButton1_Click()
   Dim Pfad As String, Datei As String
  
   With ThisWorkbook
     With .ActiveSheet
        Pfad = .Range("B3")
        Datei = .Range("B1")
     End With
     If Len(Pfad) Then If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
     On Error GoTo Err_Verzeichnis
     Application.DisplayAlerts = False
     .SaveAs Filename:=Pfad & Datei & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
     Application.DisplayAlerts = True
   End With
   Exit Sub
  
Err_Verzeichnis:
   Pfad = Test_Create_Dirs(Pfad)
   Resume
   
End Sub
Private Function Test_Create_Dirs(Pfad As String) As String
   Dim PfadBaum() As String
   Dim I As Integer, IL As Integer, IU As Integer
   
   Pfad = Trim(Pfad)
   'Falls "\" am Ende ist, entferne ihn:
   If Right(Pfad, 1) = "\" Then Pfad = Left(Pfad, Len(Pfad) - 1)
   'Zerlege 'Pfad' in seine Einzelteile:
   PfadBaum = Split(Pfad, "\")
   IL = LBound(PfadBaum): IU = UBound(PfadBaum)
   If IU >= IL + 2 Then
     'Falls 'Pfad' ein UNC-Pfad ist:
     If Len(PfadBaum(IL) & PfadBaum(IL + 1)) = 0 Then
       IL = IL + 2
       PfadBaum(IL) = "\\" & PfadBaum(IL)
     End If
   End If
   
   'Setze 'Pfad' wieder sukzessive zusammen,
   'wobei jeweils die Kind-Pfade zu testen/erzeugen sind:
   Pfad = ""
   For I = IL To IU
     Pfad = Pfad & PfadBaum(I) & "\"
     If Len(Dir(Pfad, vbDirectory)) = 0 Then
       'Kind-Verzeichnis 'Pfad' existiert nicht -> erzeuge es:
       MkDir Pfad
     End If
   Next I
   Test_Create_Dirs = Pfad
   
End Function

EDIT: Es funktioniert nur für absolute Pfade korrekt, auch UNC-Pfade sind erlaubt.

 

Wahnsinn.

Ich bin begeistert. Perfekt.

Danke für die Hilfe. Funktioniert jetzt genau wie es soll.

Und sorry, dass ich mich erst so spät melde. Ich war auf einer Schulung. Leider nicht zu VBA :-)

Noch mal ganz lieben Dank an alle, für die nützlichen Tipps.

Ganz liebe Grüße und euch allen eine supi Adventszeit

Andreas