Prompt User Folder Location and Store as Directory for Creating Folders

[kozman2]

I am looking to have users prompted for a folder location, I then want this to be stored to be used as the location where the values in columns A, B, C, etc.. will be created as a folder structure. I have read numerous forums and exhausted my VBA ability. The code I have below almost works but it only seems to store the name of the folder the user chooses then creates a folder with the user choice and the value in column A appended to it, sub folders create as expected. Thank you for any help!

Sub CreateStructure()
Dim i As Long
Dim fdDrive As FileDialog
Dim strDrive As String
Dim strlevel1 As String
Dim strLevel2 As String

Set fdDrive = Application.FileDialog(msoFileDialogFolderPicker)
With fdDrive
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    strDrive = .SelectedItems(1)
    End With

NextCode:
    GetFolder = strDrive
    Set fdDrive = Nothing

With Sheets(1).Range("A1")
    strlevel1 = .Offset(0, 0)
    MkDir strDrive & strlevel1
    For i = 1 To Sheets(1).UsedRange.Rows.Count - 1
        If .Offset(i, 0) = "" Then
            If .Offset(i, 1) <> "" Then
                strLevel2 = .Offset(i, 1)
                MkDir strDrive & strlevel1 & "\" & strLevel2
            Else
                MkDir strDrive & strlevel1 & "\" & strLevel2 & "\" & .Offset(i, 2)
           End If
        Else
            strlevel1 = .Offset(i, 0)
            MkDir strDrive & strlevel1
        End If
    Next i
End With
End Sub

[Ton(at)FINQuality]

Hi kozman2,

Didn't understand exactly what you got, but I think the problem is nog adding the slash after strDrive.

MkDir strDrive & "\"

Hope this works.

Ton

[kozman2]

Apologize if it wasn't clear but you were correct. Code below fixed the problem. Thanks!

Sub CreateStructure()
Dim i As Long
Dim fdDrive As FileDialog
Dim strDrive As String
Dim strlevel1 As String
Dim strLevel2 As String

Set fdDrive = Application.FileDialog(msoFileDialogFolderPicker)
With fdDrive
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    strDrive = .SelectedItems(1)
    End With

NextCode:
    GetFolder = strDrive
    Set fdDrive = Nothing

With Sheets(1).Range("A1")
    strlevel1 = .Offset(0, 0)
    MkDir strDrive & "\" & strlevel1
    For i = 1 To Sheets(1).UsedRange.Rows.Count - 1
        If .Offset(i, 0) = "" Then
            If .Offset(i, 1) <> "" Then
                strLevel2 = .Offset(i, 1)
                MkDir strDrive & "\" & strlevel1 & "\" & strLevel2
            Else
                MkDir strDrive & "\" & strlevel1 & "\" & strLevel2 & "\" & .Offset(i, 2)
           End If
        Else
            strlevel1 = .Offset(i, 0)
            MkDir strDrive & strlevel1
        End If
    Next i
End With
End Sub