Ordner erstellen

[PIK7]

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.

[Klaus-Dieter]

Hallo,

warum willst du eine Sache, die sich mit wenigen Mausklicks erledigen lässt, per VBA ausführen?

[PIK7]

Weil ich es sehr oft machen muss. Das würde mir sehr helfen.

[Case]

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

[Statler]

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

[RPP63]

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

[PIK7]

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!

[Statler]

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
   

[RPP63]

Ich will ja nicht meckern, aber …
… was missfällt an meinem Einzeiler?
Zu einfach?

[PIK7]

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ß