Problems creating folders

[Willow123]

Hi There,

I'm trying to create a program that will create a number of folders for a person. I have the creating part figured out but I'm having troubles specifying in what folder I want these new folders created in. I tried re-working some code I have that will pull file names out of a specific folder but unfortunately I can't get it to work for my intended purposes. Appreciate any thoughts on this. Please code below:

Sub ScriptingRunLibrary()

Dim fso As Scripting.FileSystemObject
Dim NewFolderPath As String
Dim s1 As String
Dim Target As String
Dim OldFolder As Scripting.Folder

Target = InputBox("Please Paste Target Folder Path Here")

FolderPath = Target

Set fso = New Scripting.FileSystemObject
Set OldFolder = fso.GetFolder(Target)

Range("C1").Select

For Each r In Range(ActiveCell.Offset(1, 0), ActiveCell.End(xlDown))
s1 = ActiveCell.Value
If Not fso.FolderExists(s1) Then
fso.CreateFolder s1
End If
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Exit For
End If
Next r

Set fso = Nothing

End Sub

Cheers

Trapper

 

[GWteB]

See whether this works for you. Note the two separate functions, both dependencies of the main procedure.

Sub ScriptingRunLibrary_v2()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject

    Dim RootFolder As String
    RootFolder = BrowseForFolderName

    Dim r As Excel.Range, NewFolder As String
    For Each r In Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
        NewFolder = ProperFolderPath(RootFolder) & r.Value
        If Not fso.FolderExists(NewFolder) Then
            fso.CreateFolder NewFolder
        End If
    Next r
    Set fso = Nothing
End Sub

Public Function BrowseForFolderName(Optional ByVal argFolder As String = "") As String
    With Excel.Application.FileDialog(msoFileDialogFolderPicker)
        If VBA.CreateObject("Scripting.FileSystemObject").FolderExists(argFolder) Then
            .InitialFileName = ProperFolderPath(argFolder)
        Else
            .InitialFileName = VBA.Environ("userprofile") & "\Documents\"
        End If
        If .Show Then
            BrowseForFolderName = .SelectedItems(1)
        End If
    End With
End Function

Public Function ProperFolderPath(ByVal argPath As String) As String
    Do While VBA.Right(argPath, 1) = Excel.Application.PathSeparator
        argPath = VBA.Left(argPath, VBA.Len(argPath) - 1)
    Loop
    ProperFolderPath = argPath & Excel.Application.PathSeparator
End Function

 

[Willow123]

Thank you GWteb I will give this a whirl and see how it goes.