Как создать папки с подпапками из таблицы Excel выделенных ячеек

Option Explicit  
 
Sub CreateMultiFolder()  
    Dim s As String, sF As String, sSF As String  
    Dim arr, lr As Long, lc As Long  
    Const sMainDir As String = "C:"  
      
    If Dir(sMainDir, 16) = "" Then  
        MsgBox "Корневая папка '" & sMainDir & "' отсутствует!", 
        Exit Sub  
    End If  
      
    arr = Selection.Value  
    If Not IsArray(arr) Then  
        ReDim arr(1 To 1, 1 To 1)  
        arr(1, 1) = Selection.Value  
    End If  
      
    For lr = 1 To UBound(arr, 1)  
        s = arr(lr, 1)  
        s = Trim(s)  
        If Len(s) Then  
            sF = sMainDir & arr(lr, 1)  
            If Dir(sF, 16) = "" Then  
                MkDir sF  
            End If  
            sSF = sF  
            For lc = 2 To UBound(arr, 2)  
                s = arr(lr, lc)  
                s = Trim(s)  
                If Len(s) Then  
                    sSF = sSF & "" & s  
                    If Dir(sSF, 16) = "" Then  
                        MkDir sSF  
                    End If  
                End If  
            Next lc  
        End If  
    Next lr  
End Sub

Sub CreatePathFromActiveCell()  
Dim s$  
s = "C:" & ActiveCell & "\1\2"  
If MakeSureDirectoryPathExists(s) = 0 Then MsgBox "Не удалось создать путь " & s  
End Sub

Sub CreateMultiFolder2()
    Dim s As String, sF As String, sSF As String
    Dim arr, k&, i&, j&, Strok&, Stolbcov&, LastBound&, lr As Long, lc As Long
    Const sMainDir As String = "C:" ' \-исчезает на форуме, Правильно  C:\
    If Dir(sMainDir, 16) = "" Then
        MsgBox "Корневая папка '" & sMainDir & "' отсутствует!"
        Exit Sub
    End If
    If Not IsArray(Selection.Value) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = Selection.Value
    Else
        arr = Selection.Value
        Strok = UBound(arr)
        For k = 2 To Selection.Areas.Count
            LastBound = UBound(arr, 2)
            Stolbcov = UBound(arr, 2) + Selection.Areas(k).Columns.Count
            ReDim Preserve arr(1 To Strok, 1 To Stolbcov)
            For i = 1 To Strok
                For j = 1 To Selection.Areas(k).Columns.Count
                    arr(i, LastBound + j) = Selection.Areas(k).Cells(i, j)
                Next j
            Next i
        Next
    End If
    For lr = 1 To UBound(arr, 1)
        s = arr(lr, 1)
        s = Trim(s)
        If Len(s) Then
            sF = sMainDir & arr(lr, 1)
            If Dir(sF, 16) = "" Then
                MkDir sF
            End If
            sSF = sF
            For lc = 2 To UBound(arr, 2)
                s = arr(lr, lc)
                s = Trim(s)
                If Len(s) Then
                    sSF = sSF & "" & s ' \-исчезает на форуме, Правильно  & "\
                    If Dir(sSF, 16) = "" Then
                        MkDir sSF
                    End If
                End If
            Next lc
        End If
    Next lr
End Sub

End If
    For lr = 1 To UBound(arr, 1)
        s = arr(lr, 1)
        s = Trim(s)
        If Len(s) Then
            sF = sMainDir & arr(lr, 1)
            If Dir(sF, 16) = "" Then