Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 1
Dim str$
str = Target.Value
Dim Arr
Arr = Split(str, "-")
Dim strPath As String
strPath = "O:\Kunden\" & Trim(Arr(0)) & "\" & Trim(Arr(1))
createFullPath strPath
Target.Hyperlinks.Add Target, strPath
End Select
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