Gibt es eine Möglichkeit, einen Ordner und Unterordner in Excel VBA zu erstellen?

Eine andere einfache Version, die am PC arbeitet:

Sub CreateDir(strPath As String)
    Dim Elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each Elm In Split(strPath, "\")
        strCheckPath = strCheckPath & Elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub

Ich habe einen viel besseren Weg gefunden, den gleichen Code zu verwenden, weniger Code und viel effizienter. Beachten Sie, dass "" "" den Pfad angeben soll, falls er Leerzeichen in einem Ordnernamen enthält. Befehlszeile mkdir erstellt bei Bedarf einen Zwischenordner, damit der gesamte Pfad vorhanden ist.

If Dir(YourPath, vbDirectory) = "" Then
    Shell ("cmd /c mkdir """ & YourPath & """")
End If

Private Sub CommandButton1_Click()
    Dim fso As Object
    Dim tdate As Date
    Dim fldrname As String
    Dim fldrpath As String

    tdate = Now()
    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = Format(tdate, "dd-mm-yyyy")
    fldrpath = "C:\Users\username\Desktop\FSO\" & fldrname
    If Not fso.folderexists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If
End Sub

Hier gibt es einige gute Antworten, daher werde ich nur einige Prozessverbesserungen hinzufügen. Eine bessere Methode, um festzustellen, ob der Ordner existiert (verwendet FileSystemObjects nicht, was nicht alle Computer verwenden dürfen):

Function FolderExists(FolderPath As String) As Boolean
     FolderExists = True
     On Error Resume Next
     ChDir FolderPath
     If Err <> 0 Then FolderExists = False
     On Error GoTo 0
End Function

Gleichfalls,

Function FileExists(FileName As String) As Boolean
     If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction

Dies funktioniert wie ein Zauber in AutoCad VBA und ich habe es aus einem Excel-Forum herausgeholt. Ich weiß nicht, warum Sie es alle so kompliziert machen?

HÄUFIG GESTELLTE FRAGEN

Frage: Ich bin nicht sicher, ob ein bestimmtes Verzeichnis bereits existiert. Wenn es nicht existiert, möchte ich es mit VBA-Code erstellen. Wie kann ich das machen?

Antwort: Sie können anhand des folgenden VBA-Codes testen, ob ein Verzeichnis vorhanden ist:

(Zitate werden weggelassen, um eine Verwechslung des Programmcodes zu vermeiden.)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then

   MkDir "c:\TOTN\Excel\Examples"

End If

http://www.techonthenet.com/Excel/formulas/mkdir.php

Ich habe es nie mit Nicht-Windows-Systemen versucht, aber hier ist das, was ich in meiner Bibliothek habe, ziemlich einfach zu bedienen. Keine spezielle Bibliotheksreferenz erforderlich.

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

    Dim fs As Object 
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "\" into 3 "@"
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "\")
    'then set back the @ into \ in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function

Ich weiß, dass dies beantwortet wurde und es gab bereits viele gute Antworten, aber für die Leute, die hierher kommen und nach einer Lösung suchen, könnte ich posten, was ich letztendlich beigelegt habe.

Der folgende Code behandelt beide Pfade zu einem Laufwerk (z. B. "C:\Users ...") und zu einer Serveradresse (Stil: "\ Server\Path .."). Er verwendet einen Pfad als Argument und entfernt automatisch alle Dateinamen daraus (verwenden Sie "\" am Ende, wenn es bereits ein Verzeichnispfad ist) und gibt false zurück, wenn der Ordner aus irgendeinem Grund nicht erstellt werden konnte. Ach ja, es erstellt auch Sub-Sub-Sub-Verzeichnisse, falls dies angefordert wurde.

Public Function CreatePathTo(path As String) As Boolean

Dim sect() As String    ' path sections
Dim reserve As Integer  ' number of path sections that should be left untouched
Dim cPath As String     ' temp path
Dim pos As Integer      ' position in path
Dim lastDir As Integer  ' the last valid path length
Dim i As Integer        ' loop var

' unless it all works fine, assume it didn't work:
CreatePathTo = False

' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)

' split the path into directory names
sect = Split(path, "\")

' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
    Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
    reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
    reserve = 2 ' server-path - reserve "\\Server\"
Else ' unknown type
    Exit Function
End If

' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' check if this path exists:
    If (Dir(cPath, vbDirectory) <> vbNullString) Then
        lastDir = pos
        Exit For
    End If

Next ' pos

' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' create the directory:
    MkDir cPath

Next ' pos

CreatePathTo = True
Exit Function

Error01:

End Function

Ich hoffe, dass jemand das nützlich finden kann. Genießen! :-)

Hier ist ein kurzes Sub ohne Fehlerbehandlung, das Unterverzeichnisse erstellt:

Public Function CreateSubDirs(ByVal vstrPath As String)
   Dim marrPath() As String
   Dim mint As Integer

   marrPath = Split(vstrPath, "\")
   vstrPath = marrPath(0) & "\"

   For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
      If (Dir(vstrPath, vbDirectory) = "") Then Exit For
      vstrPath = vstrPath & marrPath(mint) & "\"
   Next mint

   MkDir vstrPath

   For mint = mint To UBound(marrPath) 'create directories
      vstrPath = vstrPath & marrPath(mint) & "\"
      MkDir vstrPath
   Next mint
End Function