'Written: Shrivallabha S. Redij
Option Explicit 
Dim bResult As Boolean 
Dim i As Integer, j As Integer 
Dim lLastRow As Long, lLastCol As Long 
Dim oFSO As Object 
Dim r As Range 
Dim sVal As String, sMsg As String 
Private Sub CreateFolders_Click() 
    Dim lLastCol As Long 
    Dim sPath As String 
    Dim k As Integer 
    Dim vPath() As Variant 
     
     '***************************************************************
     'Reliable method to find out the last row of non-blank cell!
     '***************************************************************
    Set r = Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), _ 
    LookIn:=xlFormulas, LookAt:=xlPart, SearchDirection:=xlPrevious) 
    lLastRow = r.Row 
    If lLastRow < 13 Then Exit Sub 
     
    Call VerifyInput 
     '***************************************************************
     'Things are not correct so we need to check and correct them!
     '***************************************************************
    If bResult = False Then Exit Sub 
     
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
     
     'Looping through given range
    With Sheets("CreateFolders") 
        For i = 13 To lLastRow 
            If .Range("A" & i) = "" Then 
                lLastCol = .Range("A" & i).End(xlToRight).Column 
                ReDim vPath(lLastCol - 1) 
                vPath(0) = Cells(i, lLastCol).Value 
                For j = 1 To lLastCol - 1 
                    vPath(j) = Cells(i, lLastCol).Offset(, -j).End(xlUp).Value 
                Next j 
                sPath = vbNullString 
                For j = UBound(vPath) To LBound(vPath) Step -1 
                    If j = UBound(vPath) Then 
                        sPath = sPath & vPath(j) & ":" 
                    Else 
                        sPath = sPath & "\" & vPath(j) 
                    End If 
                Next j 
                On Error Resume Next 
                oFSO.CreateFolder (sPath) 
                On Error GoTo 0 
            End If 
        Next i 
    End With 
     
    Set oFSO = Nothing 
    MsgBox "Folders have been created as specified!" 
End Sub 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim sTemporary As String 
     
    On Error GoTo ErrorHandler 
     
    With Target 
        Set oFSO = CreateObject("Scripting.FileSystemObject") 
        If .Row >= 13 & .Value <> "" Then 
            sTemporary = sCorrectedPath(.Value) 
            .Value = sVal 
        End If 
         
         '***************************************************************
         'Preventing incorrect Drive Letter!
         '***************************************************************
        If .Column = 1 And .Row >= 13 And .Value <> "" Then 
            If oFSO.DriveExists(.Value) = False Then 
                MsgBox "The Drive Specified does not exist. Please Check!" 
                .Value = "" 
            End If 
        End If 
    End With 
     
ErrorHandler: 
    Select Case Err.Number 
    Case 13 
    Case 28 
    Case 91 
    Case Else 
        sMsg = "Error # " & Str(Err.Number) & " was generated by " _ 
        & Err.Source & Chr(13) & Err.Description 
        MsgBox sMsg, , "Error", Err.HelpFile, Err.HelpContext 
    End Select 
    Set oFSO = Nothing 
End Sub 
 
Private Function sCorrectedPath(sPath As String) As String 
    Dim vNotAllowed As Variant 
    Dim dPos As Double 
     
     '***************************************************************
     'Function for checking the invalid characters!
     '***************************************************************
    vNotAllowed = Array("\", "/", ":", "*", "?", Chr(34), "<", ">") 
    For i = LBound(vNotAllowed) To UBound(vNotAllowed) 
        If InStr(1, sPath, vNotAllowed(i)) = 0 Then 
            sVal = sPath 
        Else 
            dPos = InStr(1, sPath, vNotAllowed(i)) 
            sPath = Application.Replace(sPath, dPos, 1, "") 
            If Len(sPath) = 1 Then 
                sVal = UCase(sPath) 
            Else 
                sVal = sPath 
            End If 
            Exit Function 
        End If 
    Next i 
End Function 
 
Private Sub VerifyInput() 
    Dim sPath As String, sMsg As String 
    Dim k As Integer 
    Dim r As Range 
     
    bResult = True 
     
    With Sheets("CreateFolders") 
        For i = 13 To lLastRow 
             '***************************************************************
             'Verifying that at least one base drive has been specified.
             '***************************************************************
            If i = 13 And .Range("A" & i).Value = "" Then 
                MsgBox "You need to specify the Base Drive for Creating Folders" 
                .Range("A" & i).Interior.Color = vbRed 
                bResult = False 
            Else 
                Select Case .Range("A" & i).Value 
                     '***************************************************************
                     'In this case drive letter is provided so the foldername should be
                     'on next line
                     '***************************************************************
                Case Is <> "" 
                    lLastCol = .Range("A" & i).End(xlToRight).Column 
                    If lLastCol <> Columns.Count Then 
                        MsgBox "Please shift the entry to row below" & vbCr & _ 
                        "Do not write on the same line as Drive!" 
                        Cells(i, lLastCol).Interior.Color = vbBlue 
                        bResult = False 
                    End If 
                     '***************************************************************
                     'In this case Parent Folder is provided so the foldername should be
                     'on next line
                     '***************************************************************
                Case Else 
                    lLastCol = .Range("A" & i).End(xlToRight).Column 
                    If lLastCol = .Columns.Count Then 
                        MsgBox "Do not leave blank rows!" 
                        .Range("A" & i).Resize(, Columns.Count).Interior.Color = vbYellow 
                        bResult = False 
                    Else 
                        lLastCol = Cells(i, lLastCol).End(xlToRight).Column 
                        If lLastCol <> .Columns.Count Then 
                            MsgBox "Please shift the entry to row below" & vbCr & _ 
                            "Do not write on the same line as ParentFolder!" 
                            Cells(i, lLastCol).Interior.Color = vbGreen 
                            bResult = False 
                        End If 
                    End If 
                End Select 
            End If 
        Next i 
         
        Set r = Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), LookIn:=xlFormulas, LookAt:= _ 
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
        lLastCol = r.Column 
         
        For i = 2 To lLastCol 
             '***************************************************************
             'Checking for intermediate columns which are left blank
             '***************************************************************
            If Cells(13, i).End(xlDown).Row = .Rows.Count Then 
                MsgBox "Do not leave blank columns!" 
                .Range(Cells(13, i), Cells(lLastRow, i)).Interior.Color = vbYellow 
                bResult = False 
            End If 
        Next i 
    End With 
     
    If bResult = False Then 
        MsgBox "Some discrepancies are detected. Please correct them before next step!" 
    End If 
     
End Sub