Gruppe
Datei
Problem
Es sollen Verzeichnisse gemäß den Eintragungen in der Tabelle angelegt werden.
StandardModule: Modul1
Sub SetDir()
Dim iRow As Integer, iCol As Integer
Dim sDir As String, sVerz As String
iRow = 1
Do Until IsEmpty(Cells(iRow, 1))
iCol = 1
Do Until IsEmpty(Cells(iRow, iCol))
sVerz = Cells(iRow, iCol).Value
sVerz = WorksheetFunction.Substitute(sVerz, "\", "")
sDir = sDir & "\" & sVerz
If Left(sDir, 1) = "\" Then sDir = Right(sDir, Len(sDir) - 1)
On Error Resume Next
If iCol > 1 Then MkDir sDir
On Error GoTo 0
iCol = iCol + 1
Loop
sDir = ""
iRow = iRow + 1
Loop
On Error GoTo 0
End Sub