PDA

Vollständige Version anzeigen : Prüfen ob Ordner vorhanden, dann abspeichern


rooki_1
14.07.2014, 07:07
Hi,

ich habe eine Tabellenvorlage in der man die Prüflingsdaten eingibt.
B2 = Größe
B5 = Prüflingsnummer (soll dann als Ordner angelegt werden)

Ich habe ein Steuerelement "Speichern unter" angelegt, bei klick wird das Verzeichniss C:\Temp vorgeschlagen. Dann muss man noch den Unterordner mit der Nummer (B5) erstellen und Speichern drücken.
Sub Speichern_unter()

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

Verzeichnis = "C:\temp\" '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


Könnte man den Code so abändern, dass im Verzeichniss C:\Temp abgefragt wird ob der Unterordner "Nummer" (B5) schon existiert, wenn nicht dann erstellen und die Tabelle darin abspeichert wird.

Gruß Rooki

chris-kaiser
14.07.2014, 11:16
Hi,

mit
If Dir("dein_Pfad" & "\" & dein Zellname) ="" then
mkdir "dein_Pfad" & "\" & dein Zellname
end if

rooki_1
14.07.2014, 12:01
Hi,

habe das jetzt mal so:
Sub Speichern_unter()

Dim Datei As String
Dim Verzeichnis As String
Dim SaveDummy As Variant
If Dir("C:\Temp" & "\" & "B5") = "" Then
MkDir "C:\Temp" & "\" & "B5"
End If
Verzeichnis = "C:\Temp\" '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


bekomme Fehler: Fehler bei Zugriff auf Datei/Pfad

Mc Santa
14.07.2014, 12:12
Hallo,

warum lässt du einmal die Backslash weg?
Und du musst die Zelle ansprechen, dein Code schreibt nur B5
If Dir("C:\Temp" & "\" & Range("B5")) = "" Then
MkDir "C:\Temp" & "\" & Range("B5")
End If


VG

EarlFred
14.07.2014, 12:48
Hallo zusammen,

als rudimentären Code habe ich mal folgende Function zusammengebastelt, inklusive Testaufruf:
Option Explicit

Sub testaufruf()
Dim strPfad As String
strPfad = "C:\temp\meinOrdner\testverzeichnis\heute"

If chkDir(strPfad) Then MsgBox "Der Pfad existiert"

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

Damit lassen sich auch Verzeichnisse prüfen / anlegen, wenn mehr als 1 Ordner des Pfades fehlt.

Grüße
EarlFred

haklesoft
14.07.2014, 14:27
Hallo zusammen,

keine der bisher vorgestellten Lösungen berücksichtigt, dass die Rückgabe von Dir nicht unbedingt ein Verzeichnis sein muss. Das mag für den TE auch nicht relevant sein, aber andere Leser sind vielleicht irritiert.

Testmöglichkeiten, ob die Rückgabe von Dir tatsächlich ein Pfad ist

- If (GetAttr("C:\Temp") And vbDirectory) = vbDirectory Then

- oder mit ChDir hineinwechseln. Fehler 76 = Pfad existiert nicht

- oder mit MkDir anlegen. Fehler 75 = Pfad exisitert schon

EarlFred
14.07.2014, 15:26
Hallo haklesoft,

keine der bisher vorgestellten Lösungen berücksichtigt, dass die Rückgabe von Dir nicht unbedingt ein Verzeichnis sein muss
stimmt nur bedingt: In einem Ordner können nicht eine Datei und ein Verzeichnis gleichen Namens liegen. Wäre bereits eine Datei mit dem vermeintlichen Ordnernamen vorhanden, löst bei meinem Code die Fehlerbehandlung aus. Dass das kein schöner Stil ist, unterzeichne ich sofort.

Zum Thema Dir siehe auch hier: http://vb-tec.de/fdexists.htm


Grüße
EarlFred

haklesoft
14.07.2014, 15:46
Hallo EarlFred,Wäre bereits eine Datei mit dem vermeintlichen Ordnernamen vorhanden, löst bei meinem Code die Fehlerbehandlung aus.Noe, es gibt keine Meldung und keine Behandlung, wenn der letzte Teilpfad bereits als Datei existiert.

EarlFred
14.07.2014, 15:52
Hallo haklesoft,

es gibt keine Meldung.
Das habe ich nicht als Gegenstand Deines Einwands verstanden, auch erachtete es auch nicht für maßgeblich für die Fragestellung.

Wenn das "Gesuchte" kein Ordner ist, bricht der Code ab. Er berücksichtigt also indirekt auch den von Dir genannten Fall.

Bezogen auf Dein Edit:
Also bei mir gibt es in dem Fall, dass der "Pfad" als Dateiname bereits existiert, den Fehler #52 "Dateiname oder -nummer falsch"

Getestet an:
"C:\temp\1\2\3" und "C:\temp\1\2"
wobei "2" einmal ein Ordner und einmal eine Datei (ohne Endung) war und einmal mittig und einmal am Ende des Pfades stand.

Vielleicht noch als Hinweis: Der Code führt den Befehl Dir mit
"C:\temp\1\2\" aus und nicht mit "C:\temp\1\2", was den Fehler provoziert.

Wäre dennoch eine interessante Frage, ob es Konstellationen gibt, die ich nicht bedacht habe. Spätestens dann wäre es Zeit, auf vb-tec zu hören... ;)

Grüße
EarlFred

haklesoft
14.07.2014, 17:42
Hallo EarlFred,

hier mein Testablauf:

Ich habe Deinen Beispielcode (mit dem Pfad "C:\temp\meinOrdner\testverzeichnis\heute") ausgeführt.
Da bekomme ich die Meldung "der Pfad existiert". Ja, das trifft zu, denn die Unterroutine hat gerade alle Pfade angelegt.

Dann habe ich den "heute"-Pfad gelöscht und statt dessen eine Datei "heute" angelegt.
Danach habe ich wieder den Beispielcode ausgeführt, der nun aber stille schweigt, obwohl es den heute-Pfad nicht mehr gibt.

Auch wenn ich den Verzeichnisbaum ab "meinOrdner" ganz lösche und unter "C:\Temp" eine Datei "meinOrdner" anlege und den Code ausführe bleibt alles ruhig, obwohl nun der ganze Unterbaum nicht angelegt wird.

Ja, die Unterroutine hängt immer brav ein "\" an. Damit wird die sperrende Datei zwar nicht gefunden, aber das Pfadanlegen scheitert ggf. und die Routine liefert True zurück.
Als Ergänzung würde ich einen Hinweis geben im Stile von "Halt, Stopp: der gewünschte Verzeichnisbaum konnte nicht vollständig angelegt werden" und für jeden Teilpfad testen, ob es sich um ein Verzeichnis handelt und ab wann das Anlegen scheitert.

EarlFred
14.07.2014, 18:21
Hallo haklesoft,

also besteht Dein Einwand darin, dass ich der Einfachheit halber nur den positiven Fall, also dass der Pfad existiert oder angelegt werden konnte, ausgewertet habe? Es ist doch nur ein simples Beispiel gewesen und zeigt das, was den TE interessiert hat (Speichern, wenn Ordner vorhanden) - und das "Gegenteil" auszuwerten ist doch ebenso einfach zu ergänzen, wenn es einem nicht auf Differenziertheit bei der Auswertung eines Fehlers ankommt. Wollte man dies, wäre es mit der Frage, ob eine Datei mit Namen des gewünschten Verzeichnisses existiert, dann aber auch nicht getan.

aber das Pfadanlegen scheitert ggf. und die Routine liefert True zurück
Bisher habe ich keinen Hinweis darauf erhalten, dass die Function an sich unzuverlässig arbeitet. Genau dieser Fall wäre also interessant, den provoziert aber auch Dein Vorgehen nicht.

Grüße
EarlFred

rooki_1
15.07.2014, 05:50
Hi,
danke erstmal für eure rege Beteiligung an meinem Problem. Ich glaube dass ich dies aber nochmals darstellen muss.

Beim Ausführen des "Speichern unter" Makros soll abgefragt werden was in Zelle B5 steht, dies soll auch der Name des zu erstellenden Ordners sein. Daraufhin soll geprüft werden ob dieser Ordner schon im Standardverzeichniss C:\Temp existiert. Wenn nicht soll er erstellt werden, und in diesem Ordner dann die Tabelle abgespeichert werden. Wenn er schon existiert soll die Tabelle ebenfalls dort gespeichert werden.
Der Tabellenname soll folgendermasen zusammengesetzt sein: Datei = Format(Date, "yymmdd_") & Range("B2") & "_Nummer._" & Range("B5") & ".xlsm"

Gruß Rooki

EarlFred
15.07.2014, 08:31
Hallo ?,

dann nimmst Du einfach mal meine Function (schon ausprobiert?? Die Function solltest Du mit in das Modul kopieren) und schreibst die paar Zeilen zusammen:

Option Explicit

Sub testaufruf()
Dim strPfad As String
If ActiveSheet.Range("B5").Value <> "" Then
strPfad = "C:\temp\" & 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

Den Dateinamen zum Speichern hast Du ja bereits und nun auch die Gewissheit, ob der Pfad existiert (oder eben nicht). Und wenn Du nicht sicher bist, wie Du speichern sollst, liest Du bei Ron nach:
http://www.rondebruin.nl/win/s5/win001.htm

Grüße
EarlFred

rooki_1
15.07.2014, 13:48
Hi,

habe deine Funktion ausprobiert, sieht jetzt so aus:
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\" '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


Das erstellen bzw. abfragen des Verzeichnisses funzt auch, Habe aber jetz 2 Buttons. Einmal Verzeichniss abfragen/erstellen, dann ein 2. Makro zum speichern unter. Aber in das erstellte Verzeichniss springt Excel auch dann nicht.

Es wäre halt eleganter den Prozess mit einem Makro zu machen...

EarlFred
15.07.2014, 14:09
Hallo,

wo ist das Problem, die Zeile zum Speichern an der extra für diesen Zweck von mir kommentierten Stelle einzufügen?

'Code zum Sichern

Grüße
EarlFred

haklesoft
15.07.2014, 14:39
Aber in das erstellte Verzeichniss springt Excel auch dann nicht.Wie denn auch? Die Vorgabe
"C:TempmeinOrdner" entspricht so gar nicht"C:\Temp\meinOrdner\" & ActiveSheet.Range("B5").Value & "\"

rooki_1
16.07.2014, 06:27
Hi,
hab das mal bereinigt. Habe jetzt den Code so:
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


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
16.07.2014, 07:33
Siehe (http://www.ms-office-forum.net/forum/showpost.php?p=1595964&postcount=15)

EarlFred
16.07.2014, 08:05
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:
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

Demnächst hilf Dir selbst.

Grüße
EarlFred

rooki_1
16.07.2014, 08:23
Hi,

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

Sieht jetzt so aus:
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


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
16.07.2014, 08:38
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:
ActiveWorkbook.SaveAs Filename:=strPfad & Format(Date, "yymmdd_") & Range("B2") & "_Nummer._" & Range("B5") & ".xlsm", FileFormat:=52
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