Vba excel создать новую папку

I have a pull down menu of companies that is populated by a list on another sheet. Three columns, Company, Job #, and Part Number.

When a job is created I need a folder for said company and a sub-folder for said Part Number.

If you go down the path it would look like:

C:ImagesCompany NamePart Number

If either company name or Part number exists don’t create, or overwrite the old one. Just go to next step. So if both folders exist nothing happens, if one or both don’t exist create as required.

Another question is there a way to make it so it works on Macs and PCs the same?

There are some good answers on here, so I will just add some process improvements. A better way of determining if the folder exists (does not use FileSystemObjects, which not all computers are allowed to use):

Function FolderExists(FolderPath As String) As Boolean
     FolderExists = True
     On Error Resume Next
     ChDir FolderPath
     If Err <> 0 Then FolderExists = False
     On Error GoTo 0
End Function

Likewise,

Function FileExists(FileName As String) As Boolean
     If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction

answered Aug 17, 2016 at 15:26

For those looking for a cross-platform way that works on both Windows and Mac, the following works:

Sub CreateDir(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, Application.PathSeparator)
        strCheckPath = strCheckPath & elm & Application.PathSeparator
        If (Len(strCheckPath) > 1 And Not FolderExists(strCheckPath)) Then
            MkDir strCheckPath
        End If
    Next
End Sub

Function FolderExists(FolderPath As String) As Boolean
     FolderExists = True
     On Error Resume Next
     ChDir FolderPath
     If Err <> 0 Then FolderExists = False
     On Error GoTo 0
End Function

answered May 29, 2020 at 8:22

Never tried with non Windows systems, but here’s the one I have in my library, pretty easy to use. No special library reference required.

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:tototesttest") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\MyServerMyShareMyFolder")

    Dim fs As Object 
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "" into 3 "@"
    If sPath Like "\**" Then
        sPath = Replace(sPath, "", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "")
    'then set back the @ into  in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & ""
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function

answered Nov 14, 2014 at 16:56

Here’s short sub without error handling that creates subdirectories:

Public Function CreateSubDirs(ByVal vstrPath As String)
   Dim marrPath() As String
   Dim mint As Integer

   marrPath = Split(vstrPath, "")
   vstrPath = marrPath(0) & ""

   For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
      If (Dir(vstrPath, vbDirectory) = "") Then Exit For
      vstrPath = vstrPath & marrPath(mint) & ""
   Next mint

   MkDir vstrPath

   For mint = mint To UBound(marrPath) 'create directories
      vstrPath = vstrPath & marrPath(mint) & ""
      MkDir vstrPath
   Next mint
End Function

I know this has been answered and there were many good answers already, but for people who come here and look for a solution I could post what I have settled with eventually.

The following code handles both paths to a drive (like «C:Users…») and to a server address (style: «ServerPath..»), it takes a path as an argument and automatically strips any file names from it (use «» at the end if it’s already a directory path) and it returns false if for whatever reason the folder could not be created. Oh yes, it also creates sub-sub-sub-directories, if this was requested.

Public Function CreatePathTo(path As String) As Boolean

Dim sect() As String    ' path sections
Dim reserve As Integer  ' number of path sections that should be left untouched
Dim cPath As String     ' temp path
Dim pos As Integer      ' position in path
Dim lastDir As Integer  ' the last valid path length
Dim i As Integer        ' loop var

' unless it all works fine, assume it didn't work:
CreatePathTo = False

' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)

' split the path into directory names
sect = Split(path, "")

' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
    Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
    reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
    reserve = 2 ' server-path - reserve "\Server"
Else ' unknown type
    Exit Function
End If

' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' check if this path exists:
    If (Dir(cPath, vbDirectory) <> vbNullString) Then
        lastDir = pos
        Exit For
    End If

Next ' pos

' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' create the directory:
    MkDir cPath

Next ' pos

CreatePathTo = True
Exit Function

Error01:

End Function

I hope someone may find this useful. Enjoy!

answered Sep 15, 2017 at 14:15

Sub MakeAllPath(ByVal PS$)
    Dim PP$
    If PS <> "" Then
        ' chop any end  name
        PP = Left(PS, InStrRev(PS, "") - 1)
        ' if not there so build it
        If Dir(PP, vbDirectory) = "" Then
            MakeAllPath Left(PP, InStrRev(PS, "") - 1)
            ' if not back to drive then  build on what is there
            If Right(PP, 1) <> ":" Then MkDir PP
        End If
    End If
End Sub


'Martins loop version above is better than MY recursive version
'so improve to below

Sub MakeAllDir(PathS$)            

  ' format "K:firstfoldsecffold3"

  If Dir(PathS) = vbNullString Then     

 ' else do not bother

   Dim LI&, MYPath$, BuildPath$, PathStrArray$()

   PathStrArray = Split(PathS, "")

      BuildPath = PathStrArray(0) & ""    '

      If Dir(BuildPath) = vbNullString Then 

' trap problem of no drive :  path given

         If vbYes = MsgBox(PathStrArray(0) & "< not there for >" & PathS & " try to append to " & CurDir, vbYesNo) Then
            BuildPath = CurDir & ""
         Else
            Exit Sub
         End If
      End If
      '
      ' loop through required folders
      '
      For LI = 1 To UBound(PathStrArray)
         BuildPath = BuildPath & PathStrArray(LI) & ""
         If Dir(BuildPath, vbDirectory) = vbNullString Then MkDir BuildPath
      Next LI
   End If 

 ' was already there

End Sub

' use like
'MakeAllDir "K:biljoanJohno"

'MakeAllDir "K:biljoanFredso"

'MakeAllDir "K:biltomwattom"

'MakeAllDir "K:bilherbwatherb"

'MakeAllDir "K:bilherbJim"

'MakeAllDir "biljoanwat" ' default drive