Sub OrdnerstrukturAnlegen()
Dim Projekt$, Kunde$
Dim R&
Dim P1$, P2$
R = ActiveCell.Row
Kunde = Cells(R, 1)
Projekt = Cells(R, 2)
P1 = "C:\Kunden\" & Kunde
P2 = P1 & "\" & Projekt
createFullPath P2
Cells(R, 1).Hyperlinks.Add Cells(R, 1), P1
Cells(R, 2).Hyperlinks.Add Cells(R, 2), P2
End Sub
Sub createFullPath(strPath As String)
Dim FSO As Object
Dim strParentPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
Dim Drive$
Drive = Left(strPath, 3)
If Not .FolderExists(Drive) Then
MsgBox "Das Laufwerk " & Drive & " ist nicht vorhanden.", vbCritical
Exit Sub
End If
strParentPath = .GetParentFolderName(strPath)
If Not .FolderExists(strParentPath) Then createFullPath strParentPath
If Not .FolderExists(strPath) Then .CreateFolder strPath
End With
End Sub