Office: (Office 2010) Prüfen ob Ordner vorhanden, dann abspeichern

haklesoft · 12. Januar 2021

von rooki_1

Aber in das erstellte Verzeichniss springt Excel auch dann nicht.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wie denn auch? Die Vorgabe
Code:

"C:TempmeinOrdner"
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

entspricht so gar nicht Code:

"C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value & "\"
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

rooki_1 · 15. Juli 2014

Hi,
hab das mal bereinigt. Habe jetzt den Code so:
Code:

Option Explicit

Sub testaufruf()
Dim strPfad As String
If ActiveSheet.Range("B5").Value "" Then
strPfad = "C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value

If chkDir(strPfad) Then
MsgBox "Der Pfad " & strPfad & " existiert (nun)."
'Code zum Sichern
Else
MsgBox "Au weia! Der Pfad kann nicht angelegt werden? Was ist da los?", vbCritical, "Noch größere Panik!"
End If

Else
MsgBox "HILFEEEE! In B5 des aktiven Blatt steht ja garnix! Wie willst Du mit nichts einen Pfad anlegen???", vbCritical, "Panik!"
End If
End Sub

Private Function chkDir(ByVal strPfad As String) As Boolean
Dim fVerz As Variant, i As Long, strPfadTemp As String

If Right(strPfad, 1) = "" Then strPfad = Left(strPfad, Len(strPfad) - 1)
fVerz = Split(strPfad, "")
On Error GoTo errExit

For i = LBound(fVerz) To UBound(fVerz)
strPfadTemp = strPfadTemp & fVerz(i) & ""
If Len(Dir(strPfadTemp, vbDirectory)) = 0 Then MkDir strPfadTemp
Next i

errExit:
chkDir = Err = 0
End Function

Sub Speichern_unter()

Dim Datei As String
Dim Verzeichnis As String
Dim SaveDummy As Variant

Verzeichnis = "C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value & "\" 'Verzeichnis-Vorschlag
Datei = Format(Date, "yymmdd_") & Range("B2") & "_Nummer._" & Range("B5") & ".xlsm" 'Datei-Vorschlag
SaveDummy = SpeichernUnter(Verzeichnis & Datei)
If SaveDummy False Then ActiveWorkbook.SaveAs SaveDummy 'Es wurde im Dialog auf Speichern gedrückt

End Sub

Function SpeichernUnter(VorgabeName As String) As Variant

SpeichernUnter = Application.GetSaveAsFilename(InitialFileName:=VorgabeName, Filefilter:="Excel Dateien (*.xlsm),*.xls*", _
FilterIndex:=1, Title:="Speichern unter...", ButtonText:="speichern")

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Brauche hierfür aber nach wie vor 2 Makros bzw. 2 Aufrufe einmal wird das Verzeichniss erstellt beim 2. wird die Tabelle in das erstellte Verzeichniss abgespeichert. Ich bekomme es nicht hin das in ein Makro zu packen.

Gruß Rooki

haklesoft · 15. Juli 2014

Siehe

EarlFred · 15. Juli 2014

Hallo Rooki,

macht wirklich "Freude", Dir zu helfen. Warum änderst Du den Code meiner Function? So kann sie NICHT funktionieren und so ist sie auch nicht gedacht! Warum fragst Du nicht zielgerichtet nach, wenn Du etwas verstehen willst?

Und warum LIEST DU NICHT, was man Dir schreibt und worauf man Dich hinweist?

Letzte Hilfe, damit das Elend ein Ende hat:
Code:

Option Explicit

Sub speichernmiteinemklick()
Dim strPfad As String
Dim strDateiName As String

If ActiveSheet.Range("B5").Value "" Then
strDateiName = Format(Date, "yymmdd_") & Range("B2") & "_Nummer._" & Range("B5") & ".xlsm" 'Dateiname
strPfad = "C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value 'Pfad
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\" 'Pfadtrenner setzen, falls nicht vorhanden

If chkDir(strPfad) Then
MsgBox "Der Pfad " & strPfad & " existiert (nun)."
ActiveWorkbook.SaveAs Filename:=strPfad & strDateiName, FileFormat:=52
Else
MsgBox "Au weia! Der Pfad kann nicht angelegt werden? Was ist da los?", vbCritical, "Noch größere Panik!"
End If

Else
MsgBox "HILFEEEE! In B5 des aktiven Blatt steht ja garnix! Wie willst Du mit nichts einen Pfad anlegen???", vbCritical, "Panik!"
End If
End Sub

Private Function chkDir(ByVal strPfad As String) As Boolean
Dim fVerz As Variant, i As Long, strPfadTemp As String

If Right(strPfad, 1) = "\" Then strPfad = Left(strPfad, Len(strPfad) - 1)
fVerz = Split(strPfad, "\")
On Error GoTo errExit

For i = LBound(fVerz) To UBound(fVerz)
strPfadTemp = strPfadTemp & fVerz(i) & "\"
If Len(Dir(strPfadTemp, vbDirectory)) = 0 Then MkDir strPfadTemp
Next i

errExit:
chkDir = Err = 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Demnächst hilf Dir selbst.

Grüße
EarlFred

rooki_1 · 15. Juli 2014

Hi,

habe es jetzt zusammengefriemelt. War aber nicht nur eine Zeile....

Sieht jetzt so aus:
Code:

Option Explicit

Sub testaufruf()
Dim strPfad As String
Dim Verzeichnis As String
Dim Datei As String
Dim SaveDummy As Variant

If ActiveSheet.Range("B5").Value "" Then
strPfad = "C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value

If chkDir(strPfad) Then
MsgBox "Der Pfad " & strPfad & " existiert (nun)."
Verzeichnis = "C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value & "\" 'Verzeichnis-Vorschlag
Datei = Format(Date, "yymmdd_") & Range("B2") & "_Geh._" & Range("B5") & ".xlsm" 'Datei-Vorschlag
SaveDummy = SpeichernUnter(Verzeichnis & Datei) 'Code zum Sichern
If SaveDummy False Then ActiveWorkbook.SaveAs SaveDummy 'Es wurde im Dialog auf Speichern gedrückt
Else
MsgBox "Au weia! Der Pfad kann nicht angelegt werden? Was ist da los?", vbCritical, "Noch größere Panik!"
End If

Else
MsgBox "HILFEEEE! In B5 des aktiven Blatt steht ja garnix! Wie willst Du mit nichts einen Pfad anlegen???", vbCritical, "Panik!"
End If
End Sub

Private Function chkDir(ByVal strPfad As String) As Boolean
Dim fVerz As Variant, i As Long, strPfadTemp As String

If Right(strPfad, 1) = "\" Then strPfad = Left(strPfad, Len(strPfad) - 1)
fVerz = Split(strPfad, "\")
On Error GoTo errExit

For i = LBound(fVerz) To UBound(fVerz)
strPfadTemp = strPfadTemp & fVerz(i) & "\"
If Len(Dir(strPfadTemp, vbDirectory)) = 0 Then MkDir strPfadTemp
Next i

errExit:
chkDir = Err = 0
End Function

Function SpeichernUnter(VorgabeName As String) As Variant

SpeichernUnter = Application.GetSaveAsFilename(InitialFileName:=VorgabeName, Filefilter:="Excel Dateien (*.xlsm),*.xls*", _
FilterIndex:=1, Title:="Speichern unter...", ButtonText:="speichern")

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das funktioniert schon mal, wenn man aber z.B. die gleiche Datei nochmal abspeichert, wird ja abgefragt ob sie ersetzt werden soll. Wenn man hier "Nein" klickt bekomme ich einen Laufzeitfehler. Wie kann ich das noch verhindern?

Gruß Rooki

EarlFred · 15. Juli 2014

Hallo Rooki,

wenn man den Pfad zum einen fest vorgeben will und zum anderen einen Dialog zur Abfrage des gewünschten Speicherpfades und -namens will, kommt man sicher nicht mit nur einer Zeile hin. Wenn man das will, sollte man es aber auch so formulieren, damit nicht sinnlos Code produziert wird.

Für den Code, wie er nach Deiner Beschreibung sein sollte, reicht diese eine Zeile aber freilich aus:
Code:

ActiveWorkbook.SaveAs Filename:=strPfad & Format(Date, "yymmdd_") & Range("B2") & "_Nummer._" & Range("B5") & ".xlsm", FileFormat:=52
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

strPfad ist ja schon vorher mit dem Pfad belegt.

Zu Deinem Problem mit SaveAs: Probier's doch mal mit 'ner Fehlerbehandlung. Wer schon 4 Jahre VBA programmiert, sollte doch wissen, wie das geht. Oder weiß zumindest, was er bei Google eingeben muss.

Grüße
EarlFred

Office: (Office 2010) Prüfen ob Ordner vorhanden, dann abspeichern

Prüfen ob Ordner vorhanden, dann abspeichern

Prüfen ob Ordner vorhanden, dann abspeichern

Prüfen ob Ordner vorhanden, dann abspeichern

Prüfen ob Ordner vorhanden, dann abspeichern - Similar Threads - Prüfen Ordner vorhanden

VBA prüfen - eventuell Fehler

Access VBA – Prüfen, ob eine PDF bereits geöffnet ist, bevor sie erneut geöffnet wird

Formeltext auf Bezüge/Ausdrücke prüfen

Zelle per VBA auf ihren Inhalt prüfen und reagieren sowie bei Änderung

Prüfung unterschiedlicher Zellen auf Inhalt und Konsequenz

mit String aus Formular Übereinstimmung in Abfrage prüfen

Prüfen ob Netzwerk Ordner existiert