Create new sub folder

**mikey3580** · 08-19-2015, 11:30 AM

Hello,

Does anyone know a quick code to create a sub folder under the parent directory listed in column A.
I have about 600 different parent directories in column A and the new folder I need to create is in the corresponding row next to it in Column B. column B names are all different as well. I want to check if the new folder exists listed in column B already and if it doesn't create a new folder. If it does already exist, move on. Anyone know a quick way to do this?

Thanks!!!

**cyiangou** · 08-19-2015, 11:36 AM

This will create all the sub paths necessary to fulfill the DestPath:

Public Function CreatePath(ByVal DestPath As String) As Boolean
  Dim TempDir As String
  Dim ForePos As Integer
  Dim Term As Long
  Dim IsUNC As Boolean
  DestPath = Wack(Trim$(DestPath))
  IsUNC = DestPath Like "\\*"
  If IsUNC Then
    ForePos = InStr(3, DestPath, "\")
  Else
    ForePos = InStr(4, DestPath, "\")
  End If
  Term = 1
  Do While ForePos <> 0
    TempDir = Left$(DestPath, ForePos - 1)
    If Not (IsUNC And Term <= 2) Then
      On Error Resume Next
      Err = 0
      MkDir TempDir
      If Err <> 0 And Err <> 75 Then
        GoTo ErrorOut
      End If
      Err = 0
    End If
    ForePos = InStr(ForePos + 1, DestPath, "\")
    Term = Term + 1
  Loop
  CreatePath = True
  Exit Function
                 
ErrorOut:
  MsgBox Error$, vbExclamation
  CreatePath = False
End Function

**mikey3580** · 08-19-2015, 12:54 PM

Originally Posted by cyiangou

This will create all the sub paths necessary to fulfill the DestPath:

Public Function CreatePath(ByVal DestPath As String) As Boolean
  Dim TempDir As String
  Dim ForePos As Integer
  Dim Term As Long
  Dim IsUNC As Boolean
  DestPath = Wack(Trim$(DestPath))
  IsUNC = DestPath Like "\\*"
  If IsUNC Then
    ForePos = InStr(3, DestPath, "\")
  Else
    ForePos = InStr(4, DestPath, "\")
  End If
  Term = 1
  Do While ForePos <> 0
    TempDir = Left$(DestPath, ForePos - 1)
    If Not (IsUNC And Term <= 2) Then
      On Error Resume Next
      Err = 0
      MkDir TempDir
      If Err <> 0 And Err <> 75 Then
        GoTo ErrorOut
      End If
      Err = 0
    End If
    ForePos = InStr(ForePos + 1, DestPath, "\")
    Term = Term + 1
  Loop
  CreatePath = True
  Exit Function
                 
ErrorOut:
  MsgBox Error$, vbExclamation
  CreatePath = False
End Function

Shouldn't this be a Sub and not a function? I can not get this to work

Thanks

**YasserKhalil** · 08-19-2015, 12:30 PM

@cyiangou
I think there is error in this udf function
Can you guide us how to use it?
Thanks advanced

**YasserKhalil** · 08-19-2015, 01:03 PM

Suppose your data in column A and sub folders names in column B
Try this code

Sub CreateDirs()
    Dim Rng As Range, RW As Range, CL As Range
    Const RootFolder = "C:\ExcelForum"   'Change To Suit
    Set Rng = Range("A1:B5") 'Change To Suit

    For Each RW In Rng.Rows
        ChDir RootFolder
        For Each CL In RW.Cells
            On Error Resume Next
            If CL <> "" Then
                MkDir CL
                ChDir CL
            End If
            On Error GoTo 0
        Next
    Next
End Sub

**shg** · 08-19-2015, 01:13 PM

Here's what I use:

Sub Demo()
  MakeDirs Intersect(Columns("A"), ActiveSheet.UsedRange).Value
End Sub

Sub MakeDirs(avsDir As Variant)
  ' shg 2008
  Dim vsDir         As Variant

  For Each vsDir In avsDir
    vsDir = CStr(vsDir)
    If Len(vsDir) Then
      Select Case MakeDir(vsDir)
        Case -1
          MsgBox Prompt:="MakeDirs: Directory  """ & vsDir & """ already exists", _
                 Title:="Oops!"
        Case 0
          MsgBox Prompt:="MakeDirs: Unable to create """ & vsDir & """", _
                 Title:="Oops!"
      End Select
    End If
  Next vsDir
End Sub

Function MakeDir(ByVal sDir As String) As Long
  ' shg 2008
  ' Returns -1 if sDir already exists
  '     1 if sDir is successfully created
  '     0 if sDir cannot be created

  Dim sPS           As String
  Dim astr()        As String
  Dim iLvl          As Long

  If Len(Dir(sDir, vbDirectory)) Then
    MakeDir = -1

  Else
    sPS = Application.PathSeparator

    If Right(sDir, 1) = sPS Then sDir = Left(sDir, Len(sDir) - 1)
    astr = Split(sDir, sPS)
    sDir = vbNullString

    ' MkDir will fail if sDir contains character codes 0-31
    ' or any of the characters ' < > : " / \ | ? *
    ' or if the drive does not exist,
    ' or if the user does not have permissions, so ...
    On Error GoTo Oops

    For iLvl = 0 To UBound(astr)
      sDir = sDir & astr(iLvl) & sPS
      If Len(Dir(sDir, vbDirectory)) = 0 Then MkDir sDir
    Next iLvl

    MakeDir = 1
  End If
OuttaHere:
  Exit Function

Oops:
  Err.Clear
  Resume OuttaHere
End Function

**cyiangou** · 08-19-2015, 01:45 PM

@cyiangou
I think there is error in this udf function
Can you guide us how to use it?

Just call it like this:

CreatePath "C:\folder1\folder2\folder3"

it should build all the levels if they don't exist.

Shouldn't this be a Sub and not a function? I can not get this to work

It's configured as a function if you want to get success/failure info from it, but just call it like a sub.

It should work perfectly. This particular proc I have used unchanged for almost 20 years (as evidenced by my 2 space indentation).

Create new sub folder

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Create new sub folder

Re: Create new sub folder

Re: Create new sub folder

Re: Create new sub folder

Re: Create new sub folder

Re: Create new sub folder

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Loop Through Folder, Create Emails with Sub Folder Names in Subject, Attach files in sub

Create FOLDER in subfoldesr and move folders with specific names into FOLDER

Code to create New Folder (if doesn't exist) and then Save Workbook to folder

Is there a way to create a script that will create a folder and sub folder if none exist?

create a compressed folder or zipped folder then copy workbooks to it.

Create Folder with system date then save file to folder

Save file in a new folder, but create folder only if folder doesn't already exist?

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions