Excel VBA에 폴더 및 하위 폴더 만들기

Excel VBA에 폴더 및 하위 폴더 만들기

다른 시트에 목록으로 채워진 회사의 풀다운 메뉴가 있습니다.세 개의 열, 회사, 작업 번호 및 부품 번호.

작업이 생성되면 해당 회사의 폴더와 해당 부품 번호의 하위 폴더가 필요합니다.

그 길을 따라가면 다음과 같습니다.

C:\Images\회사 이름\부품 번호\

회사 이름 또는 부품 번호가 있으면 이전 제품을 만들거나 덮어쓰지 않습니다.다음 단계로 이동합니다.따라서 두 폴더가 모두 존재하는 경우에는 아무 일도 일어나지 않으며, 하나 또는 둘 다 존재하지 않는 경우에는 필요에 따라 생성합니다.

또 다른 질문은 Mac과 PC에서 동일하게 작동하도록 만드는 방법이 있습니까?

PC에서 작동하는 또 다른 간단한 버전:

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

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub

하나의 서브와 두 개의 함수.하위 항목은 경로를 작성하고 기능을 사용하여 경로가 존재하는지 확인하고 존재하지 않으면 생성합니다.전체 경로가 이미 존재하는 경우에는 그냥 지나갑니다.PC에서도 작동하지만 Mac에서도 작동하려면 수정해야 할 항목을 확인해야 합니다.

'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

저는 훨씬 더 나은 방법을 찾았습니다. 코드를 덜 사용하고 훨씬 더 효율적입니다.""는 폴더 이름에 공백이 포함된 경우 경로를 따옴표로 묶는 것입니다.명령줄 mkdir는 전체 경로가 존재하도록 하기 위해 필요한 경우 모든 중간 폴더를 생성합니다.

If Dir(YourPath, vbDirectory) = "" Then
    Shell ("cmd /c mkdir """ & YourPath & """")
End If

Private Sub CommandButton1_Click()
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String

    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = Format(Now(), "dd-mm-yyyy")
    fldrpath = "C:\Temp\" & fldrname
    If Not fso.FolderExists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If
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

저도 마찬가지예요.

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

Function MkDir(ByVal strDir As String)
    Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(strDir) Then
        ' create parent folder if not exist (recursive)
        MkDir (fso.GetParentFolderName(strDir))
        ' doesn't exist, so create the folder
        fso.CreateFolder strDir
    End If
End Function

이것은 AutoCad VBA에서 매력적으로 작동하며 엑셀 포럼에서 얻었습니다.왜 그렇게 복잡하게 만드는지 모르겠어요?

자주 묻는 질문

질문:.특정 디렉터리가 이미 있는지 잘 모르겠습니다.만약 없다면 VBA 코드를 사용하여 만들고 싶습니다.어떻게 해야 하나요?

답변: 아래의 VBA 코드를 사용하여 디렉터리가 있는지 테스트할 수 있습니다.

(프로그래밍 코드의 혼동을 피하기 위해 아래 인용문은 생략)

---

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then

   MkDir "c:\TOTN\Excel\Examples"

End If

---

http://www.techonthenet.com/excel/formulas/mkdir.php

Windows와 Mac 모두에서 작동하는 교차 플랫폼 방식을 찾는 사용자에게 다음과 같은 이점이 있습니다.

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

Windows 이외의 시스템에서는 사용해 본 적이 없지만, 여기 제 라이브러리에 있는 사용하기 쉬운 시스템이 있습니다.특별한 라이브러리 참조가 필요하지 않습니다.

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

하위 디렉터리를 만드는 오류 처리가 없는 짧은 하위 디렉터리는 다음과 같습니다.

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

이것이 답변되었고 이미 많은 좋은 답변들이 있었다는 것을 알지만, 여기에 와서 해결책을 찾는 사람들을 위해 저는 결국 제가 해결한 것을 게시할 수 있습니다.

다음 코드는 "C:"와 같이 드라이브에 대한 두 경로를 모두 처리합니다.\사용자...") 및 서버 주소(스타일: "\Server\Path.")에 대한 경로를 사용하여 자동으로 파일 이름을 제거합니다(이미 디렉터리 경로인 경우 "\"를 끝에 사용). 폴더를 만들 수 없는 경우 false를 반환합니다.요청한 경우 하위 하위 하위 디렉터리도 만듭니다.

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

누군가가 이것을 유용하게 생각하기를 바랍니다.맛있게 드세요! :-)

이 버전은 UNC뿐만 아니라 레터 드라이브에서도 작동하는 재귀 버전입니다. 오류 감지 기능을 사용하여 구현했지만, 사용하지 않고도 실행할 수 있는 사람이 있다면 보고 싶습니다.이 접근 방식은 분기에서 루트로 작동하므로 디렉터리 트리의 루트 및 하위 부분에 권한이 없을 때 다소 사용할 수 있습니다.

' 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

Sub FolderCreate()
    MkDir "C:\Test"
End Sub

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:\firstfold\secf\fold3"

  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:\bil\joan\Johno"

'MakeAllDir "K:\bil\joan\Fredso"

'MakeAllDir "K:\bil\tom\wattom"

'MakeAllDir "K:\bil\herb\watherb"

'MakeAllDir "K:\bil\herb\Jim"

'MakeAllDir "bil\joan\wat" ' default drive

언급URL : https://stackoverflow.com/questions/10803834/create-a-folder-and-sub-folder-in-excel-vba