VBA Ordner und Unterordner flexibel erst

Hallo zusammen
Kann mir jemand helfen den Code anzupassen?
Ich habe diesen im Internet gefunden, und möchte gerne das in der Spalte B die Namen der UnterOrdner eingetragen werden können.
Ist das möglich?

Besten Dank im Voruas

Option Explicit

Function ordnerda(strPfad As String) As Boolean

If Right(strPfad, 1) = "\" Then strPfad = Left(strPfad, Len(strPfad) - 1)
If LCase(Dir(strPfad, vbDirectory)) = LCase(Split(strPfad, "\")(UBound(Split(strPfad, "\")))) Then ordnerda = True

End Function

Sub OrdnerErstellen()
Dim fso As Object
Dim i As Integer
Dim strPfad As String
Dim appWord As Object
Dim strText As String
Set fso = CreateObject("Scripting.Filesystemobject")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
strPfad = ThisWorkbook.Path & "\" & Cells(i, 1)
If Not ordnerda(strPfad) Then
MkDir strPfad
MkDir strPfad & "\00_Archiv"
MkDir strPfad & "\01_Korrespondenz"
MkDir strPfad & "\02_SAR"
MkDir strPfad & "\03_Unterlagen"
MkDir strPfad & "\04_Fotos"
End If
Next i
Set fso = Nothing
strText = " Die Ordner mit den Dokumenten wurden angelegt !!!"
MsgBox strText, 64, "Meldung"
End Sub