Sub CreateFoldersAndSubfoldersWithUserInput()
'Updateby Extendoffice
   Dim Rng As Range
   Dim Cell As Range
   Dim basePath As String
   Dim fldrPicker As FileDialog
   Dim FolderPath As String, subfolderPath As String
   On Error Resume Next
   Set Rng = Application.InputBox("Select the range of cells (two columns: one is folder column, another s subfolder column):", "Kutools for Excel", Type:=8)
   If Rng Is Nothing Then Exit Sub
   On Error GoTo 0
   Set fldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
   With fldrPicker
       .Title = "Select the Base Folder Path"
       .AllowMultiSelect = False
       If .Show <> -1 Then Exit Sub
       basePath = .SelectedItems(1)
   End With
   If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
   For Each Cell In Rng.Columns(1).Cells
       If Not Cell.Value = "" Then
           FolderPath = basePath & ReplaceSymbols(Cell.Value)
           If Not FolderExists(FolderPath) Then MkDir FolderPath
           If Not Cell.Offset(0, 1).Value = "" Then
               subfolderPath = FolderPath & "\" & ReplaceSymbols(Cell.Offset(0, 1).Value)
               If Not FolderExists(subfolderPath) Then MkDir subfolderPath
           End If
       End If
   Next Cell
End Sub

Function FolderExists(FolderPath As String) As Boolean
   On Error Resume Next
   FolderExists = (GetAttr(FolderPath) And vbDirectory) = vbDirectory
   On Error GoTo 0
End Function

Function ReplaceSymbols(ByVal txt As String) As String

    Dim strSymbols As String, i%
    strSymbols = "\/:*?""<>|~!@#$%^&=`"
    For i = 1 To Len(strSymbols)
        txt = Replace(txt, Mid(strSymbols, i, 1), "_")
    Next
    ReplaceSymbols = txt
    
End Function