Thema: Vorhandensein von Verzeichnissen prüfen und Ordner anlegen

StandardModule: Modul1

Sub Pruefen()
   Dim arrOrdner As Variant
   Dim iOrdner As Integer
   Dim sDrive As String, sOrdner As String, sTmp As String
   sOrdner = InputBox("Zu erstellendes Verzeichnis:", , Range("B1").Value)
   If sOrdner = "" Then Exit Sub
   If Right(sOrdner, 1) = "\" Then
      sOrdner = Left(sOrdner, Len(sOrdner) - 1)
   End If
   arrOrdner = fncFolders(sOrdner)
   For iOrdner = UBound(arrOrdner) To 1 Step -1
      If fncIfFolderExists(CStr(arrOrdner(iOrdner))) Then
         MsgBox "Ordner " & arrOrdner(iOrdner) & " ist bereits vorhanden!"
      Else
         MkDir arrOrdner(iOrdner)
      End If
   Next iOrdner
End Sub

Private Function fncFolders(sFolder As String) As Variant
   Dim arr() As String
   Dim iCounter As Integer, iFolder As Integer
   ReDim arr(1 To 1)
   arr(1) = sFolder
   iFolder = 1
   For iCounter = Len(sFolder) To 4 Step -1
      If Mid(sFolder, iCounter, 1) = "\" Or iCounter = 1 Then
         iFolder = iFolder + 1
         ReDim Preserve arr(1 To iFolder)
         arr(iFolder) = Left(sFolder, iCounter - 1)
      End If
   Next iCounter
   fncFolders = arr
End Function

Private Function fncIfFolderExists(sFolder As String) As Boolean
   Dim sOld As String
   sOld = CurDir
   On Error Resume Next
   ChDrive Left(sFolder, 1)
   ChDir sFolder
   If Err = 0 Then fncIfFolderExists = True
   On Error GoTo 0
   ChDrive Left(sOld, 1)
   ChDir sOld
End Function

Beiträge aus dem Excel-Forum zu den Themen Datei und Verzeichnis