Create a folder and sub folder in Excel VBA

后端 未结 13 1453
梦谈多话
梦谈多话 2020-11-28 05:43

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 fo

相关标签:
13条回答
  • 2020-11-28 06:09

    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
    
    0 讨论(0)
  • 2020-11-28 06:12

    One sub and two functions. The sub builds your path and use the functions to check if the path exists and create if not. If the full path exists already, it will just pass on by. This will work on PC, but you will have to check what needs to be modified to work on Mac as well.

    'requires reference to Microsoft Scripting Runtime
    Sub MakeFolder()
    
    Dim strComp As String, strPart As String, strPath As String
    
    strComp = Range("A1") ' assumes company name in A1
    strPart = CleanName(Range("C1")) ' assumes part in C1
    strPath = "C:\Images\"
    
    If Not FolderExists(strPath & strComp) Then 
    'company doesn't exist, so create full path
        FolderCreate strPath & strComp & "\" & strPart
    Else
    'company does exist, but does part folder
        If Not FolderExists(strPath & strComp & "\" & strPart) Then
            FolderCreate strPath & strComp & "\" & strPart
        End If
    End If
    
    End Sub
    
    Function FolderCreate(ByVal path As String) As Boolean
    
    FolderCreate = True
    Dim fso As New FileSystemObject
    
    If Functions.FolderExists(path) Then
        Exit Function
    Else
        On Error GoTo DeadInTheWater
        fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
        Exit Function
    End If
    
    DeadInTheWater:
        MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
        FolderCreate = False
        Exit Function
    
    End Function
    
    Function FolderExists(ByVal path As String) As Boolean
    
    FolderExists = False
    Dim fso As New FileSystemObject
    
    If fso.FolderExists(path) Then FolderExists = True
    
    End Function
    
    Function CleanName(strName as String) as String
    'will clean part # name so it can be made into valid folder name
    'may need to add more lines to get rid of other characters
    
        CleanName = Replace(strName, "/","")
        CleanName = Replace(CleanName, "*","")
        etc...
    
    End Function
    
    0 讨论(0)
  • 2020-11-28 06:12

    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:\toto\test\test") Then debug.print "OK"
    'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")
    
        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
    
    0 讨论(0)
  • 2020-11-28 06:15

    This is a recursive version that works with letter drives as well as UNC. I used the error catching to implement it but if anyone can do one without, I would be interested to see it. This approach works from the branches to the root so it will be somewhat usable when you don't have permissions in the root and lower parts of the directory tree.

    ' Reverse create directory path. This will create the directory tree from the top    down to the root.
    ' Useful when working on network drives where you may not have access to the directories close to the root
    Sub RevCreateDir(strCheckPath As String)
        On Error GoTo goUpOneDir:
        If Len(Dir(strCheckPath, vbDirectory)) = 0 And Len(strCheckPath) > 2 Then
            MkDir strCheckPath
        End If
        Exit Sub
    ' Only go up the tree if error code Path not found (76).
    goUpOneDir:
        If Err.Number = 76 Then
            Call RevCreateDir(Left(strCheckPath, InStrRev(strCheckPath, "\") - 1))
            Call RevCreateDir(strCheckPath)
        End If
    End Sub
    
    0 讨论(0)
  • 2020-11-28 06:20

    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
    
    0 讨论(0)
  • 2020-11-28 06:20

    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: "\Server\Path.."), 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! :-)

    0 讨论(0)
提交回复
热议问题