Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Vorhandensein von Verzeichnissen prüfen und Ordner anlegen

Gruppe

Verzeichnis

Problem

Es soll geprüft werden, ob ein Verzeichnis mit Unterverzeichnissen bereits besteht. Wenn ja, soll eine entsprechende Meldung erfolgen, wenn nein sollen sie erstellt werden.

Lösung
Den nachstehenden Code in ein Standardmodul eingeben, einer Schaltfläche zuweisen und starten.

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