Hallo zusammen,
Ich möchte aus excel heraus einen Ordner erstellen und in den gerade erzeugten Ordner einen weiteren ordner einfügen.
Den ersten ordner anlegen funktioniert wie folgt einwandfrei:
' Ordner anlegen
Const paTh = "W:\Ordner1\Ordner2\Ordner3\" ' Anpassen!
On Error GoTo errorHandler
With ActiveSheet.Cells(1, 10)
If Dir(paTh & .Text, vbDirectory) = "" Then
MkDir paTh & .Value
Else
MsgBox ("Autsch, dieser Ordner existiert bereits")
End If
End With
Exit Sub
errorHandler:
MsgBox ("Fehler beim Anlegen des Verzeichnisses.")
End Sub
Wie bekomme ich es jetzt hin, in dem gerade erzeugten Ordner jetzt automatisch einen Unter-Ordner einzufügen, der immer den Namen "Doku" hat?
Ich hoffe ich konnte es verständlich erklären.
Hallo,
warum willst du eine Sache, die sich mit wenigen Mausklicks erledigen lässt, per VBA ausführen?
Weil ich es sehr oft machen muss. Das würde mir sehr helfen.
Hallo, :19:
probiere es mal so: :21:
Code:
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" _
(ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#Else
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" _
(ByVal pszPath As String) As Long
Private Declare Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If
Const strPath As String = "C:\Temp\" ' Pfad anpassen!!!!! Abschließender Backslash NICHT vergessen!!!!
Public Sub Main()
Dim strFolder As String
On Error GoTo Fin
With ActiveSheet
If Trim(.Cells(1, 10).Value) <> "" Then
strFolder = strPath & .Cells(1, 10).Value
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
If PathFileExists(strFolder) <> 0 Then
MsgBox "Ordner vorhanden!"
Else
MakeSureDirectoryPathExists (strFolder & "\Doku\")
End If
Else
MsgBox "Zelle J1 leer!"
End If
End With
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Hallo,
verstehe ich die Frage richtig? Du möchtest dann nur einmalig einen weiteren Unterordner anlegen?
Das würde einfach mit der Anweisung gehen:
Sub Test()
Const paTh = "c:\Temp\Test2" ' Anpassen!
On Error GoTo errorHandler
With ActiveSheet.Cells(1, 10)
If Dir(paTh & .Text, vbDirectory) = "" Then
MkDir paTh & .Value
MkDir paTh & Value & "\Doku"
Else
MsgBox ("Autsch, dieser Ordner existiert bereits")
End If
End With
Exit Sub
errorHandler:
MsgBox ("Fehler beim Anlegen des Verzeichnisses.")
End Sub
Gruß
Statler
Die API, die Case genannt hat, hat einen gewaltigen Vorteil!
Man muss sich nicht erst mühsam durch die Verzeichnisebenen hangeln, sondern kann (auf dem ansonsten leeren Laufwerk X:) gleich den Ordner
X:\1\2\3\4\Doku
erstellen.
Alternative ohne API:
Code:
Sub CreatePath_Alternative_ohne_API()
On Error Resume Next
CreateObject("shell.application").Namespace("X:").newfolder "\1\2\3\4\Doku"
On Error GoTo 0
End Sub
Hallo Statler,
Deine Vorschlag habe ich gerade ausprobiert.
Ein "Doku" Ordner wird zwar erstellt aber leider nicht in dem gerade zuvor erstelltem Ordner sondern eine Ebene darüber.
Hast Du noch ne Idee?
Ich würd eine Lösung bevorzugen, bei der ich meine VBA nicht allzuviel abänder müßte. Aber wenns nicht anders geht...
Danke schon mal!
Hallo pik7,
denn setzte doch mal 3 MsgBoxen und schreib mal was die ausgeben.
With ActiveSheet.Cells(1, 10)
If Dir(paTh & .Text, vbDirectory) = "" Then
MsgBox(paTh)
MkDir paTh & .Value
MsgBox(path & .Value)
MkDir paTh & Value & "\Doku"
MsgBox (path & Value & "\Doku")
Else
MsgBox ("Autsch, dieser Ordner existiert bereits")
End If
End With
Ich will ja nicht meckern, aber …
… was missfällt an meinem Einzeiler?
Zu einfach?
Hallo Statler,
erste Fehlermeldung: W:\FGW\FGW-Vertrieb\FGW Angebote_2020\ ( Das ist der Pfad in dem der neue Angebotsordner angelegt werden soll und das funktionierte bislang auch). In diesen Ordner soll noch der Ordner Doku erstellt werden.
zweite Fehlermeldung: W:\FGW\FGW-Vertrieb\FGW Angebote_2020\4041_P110-3_SelexES_28.02.2020 (4041_P110-3_SelexES_28.02.2020 ist der gerade neu erstellte Angebotsordner, das hat er gemacht)
dritte Fehlermeldung: Fehler beim Anlegen des Verzeichnisses
Gruß