Hallo zusammen
Kann mir jemand helfen den Code anzupassen?
Ich habe diesen im Internet gefunden, und möchte gerne das in der Spalte B die Namen der UnterOrdner eingetragen werden können.
Ist das möglich?
Besten Dank im Voruas
Option Explicit
Function ordnerda(strPfad As String) As Boolean
If Right(strPfad, 1) = "\" Then strPfad = Left(strPfad, Len(strPfad) - 1)
If LCase(Dir(strPfad, vbDirectory)) = LCase(Split(strPfad, "\")(UBound(Split(strPfad, "\")))) Then ordnerda = True
End Function
Sub OrdnerErstellen()
Dim fso As Object
Dim i As Integer
Dim strPfad As String
Dim appWord As Object
Dim strText As String
Set fso = CreateObject("Scripting.Filesystemobject")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
strPfad = ThisWorkbook.Path & "\" & Cells(i, 1)
If Not ordnerda(strPfad) Then
MkDir strPfad
MkDir strPfad & "\00_Archiv"
MkDir strPfad & "\01_Korrespondenz"
MkDir strPfad & "\02_SAR"
MkDir strPfad & "\03_Unterlagen"
MkDir strPfad & "\04_Fotos"
End If
Next i
Set fso = Nothing
strText = " Die Ordner mit den Dokumenten wurden angelegt !!!"
MsgBox strText, 64, "Meldung"
End Sub