Private Sub Worksheet_Change(ByVal Target As Range)
Const basisPfad As String = "\\sharedfolder\allgemein\Lauer\"
Dim fso
Dim pNr As String
Dim pName As String
Dim folderName As String
On Error GoTo fehler
If Target.Cells.Count > 1 Then Exit Sub
If Target.Row > 2 And Target.Column = 1 Or Target.Column = 2 Then
pNr = Me.Cells(Target.Row, "A").Text
pName = Me.Cells(Target.Row, "B").Text
If pNr <> "" And pName <> "" Then
Set fso = CreateObject("Scripting.FileSystemObject")
folderName = basisPfad & UCase(Left(pName, 1)) & "\"
If Not fso.FolderExists(folderName) Then fso.createFolder folderName
folderName = folderName & pNr & " " & pName & "\"
If Not fso.FolderExists(folderName) Then fso.createFolder folderName
End If
End If
Exit Sub
fehler:
MsgBox "Fehler: " & Err.Description
End Sub