없는 경우 폴더 경로 만들기(VBA에서 저장)

없는 경우 폴더 경로 만들기(VBA에서 저장)

다음과 같은 시트에 항목 목록이 있습니다.

제 코드는 각 행을 거쳐 공급업체를 그룹화하고 일부 정보를 각 공급업체의 워크북에 복사합니다.이 시나리오에서는 2개의 고유 공급업체가 있으므로 2개의 워크북이 생성됩니다.효과가 있습니다.

다음으로 각 워크북을 특정 폴더 경로에 저장합니다.폴더 경로가 존재하지 않으면 생성해야 합니다.

이 비트에 대한 코드 조각은 다음과 같습니다.

'Check directort and save
                Path = "G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\" & .Range("H" & i) & "\KW " & .Range("A" & i) & "\"
                
                If Dir(Path, vbDirectory) = "" Then
                Shell ("cmd /c mkdir """ & Path & """")
                End If
                
                wbTemplate.SaveCopyAs Filename:=Path & file & " - " & file3 & " (" & file2 & ").xlsx"

디렉토리가 존재하는 경우에는 두 워크북이 모두 저장되지만 디렉토리가 존재하지 않아 작성해야 하는 경우에는 워크북이 하나만 저장됩니다.

전체 코드:

Sub Create()
'On Error GoTo Message
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
    Dim WbMaster As Workbook
    Dim wbTemplate As Workbook
    Dim wStemplaTE As Worksheet
    Dim i As Long
    Dim Lastrow As Long
    Dim rngToChk As Range
    Dim rngToFill As Range
    Dim rngToFill2 As Range
    Dim rngToFill3 As Range
    Dim rngToFill4 As Range
    Dim rngToFill5 As Range
    Dim rngToFill6 As Range
    Dim rngToFill7 As Range
    Dim rngToFill8 As Range
    Dim rngToFill9 As Range
    Dim rngToFil20 As Range
    Dim CompName As String
    Dim WkNum As Integer
    Dim WkNum2 As Integer
    Dim WkNum3 As Integer
    Dim WkNum4 As Integer
    
    Dim FilePath1 As String
    Dim TreatedCompanies As String
    Dim FirstAddress As String
    '''Reference workbooks and worksheet
    Set WbMaster = ThisWorkbook
    
    WkNum = Left(ThisWorkbook.Worksheets(1).Range("C5").Value, (InStr(1, ThisWorkbook.Worksheets(1).Range("C5").Value, " - ")) - 1)
    WkNum2 = Trim(WkNum)
    WkNum3 = Right(ThisWorkbook.Worksheets(1).Range("C5").Value, (InStr(1, ThisWorkbook.Worksheets(1).Range("C5").Value, " - ")) - 1)
    WkNum4 = Trim(WkNum3)
    
    '''Loop through Master Sheet to get wk numbers and supplier names
    With WbMaster.Sheets(1)
    Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    
    For i = 11 To Lastrow
    
    Set rngToChk = .Range("A" & i)
    MyWeek = rngToChk.Value
    CompName = rngToChk.Offset(0, 5).Value
    
    'Check Criteria Is Met
    If MyWeek >= WkNum2 And MyWeek <= WkNum4 And InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then
    
    
    
    
    'Start Creation
        '''Company already treated, not doing it again
            Else
                '''Open a new template
                On Error Resume Next
                Set wbTemplate = Workbooks.Open("G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\Announcement Template.xlsx")
                Set wStemplaTE = wbTemplate.Sheets(1)

                '''Set Company Name to Template
                wStemplaTE.Range("C13").Value = CompName
                   
                
                '''Add it to to the list of treated companies
                TreatedCompanies = TreatedCompanies & "/" & CompName
                '''Define the 1st cell to fill on the template
                Set rngToFill = wStemplaTE.Range("A31")
                
                
                'Remove uneeded announcement rows
                'wStemplaTE.Range("A31:A40").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True


                
                'On Error GoTo Message21
                'Create Folder Directory
                file = AlphaNumericOnly(.Range("G" & i))
                file2 = AlphaNumericOnly(.Range("C" & i))
                file3 = AlphaNumericOnly(.Range("B" & i))
                
                'Check directort and save
                Path = "G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\" & .Range("H" & i) & "\KW " & .Range("A" & i) & "\"
                
                If Dir(Path, vbDirectory) = "" Then
                Shell ("cmd /c mkdir """ & Path & """")
                End If
                
                wbTemplate.SaveCopyAs Filename:=Path & file & " - " & file3 & " (" & file2 & ").xlsx"
                
                wbTemplate.Close False
            
            
            End If
                 

    Next i
    
    End With

                            
End Sub



Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

폴더가 있는지 확인해야 합니다.그렇지 않다면, 그것을 만드세요.이 기능이 작동합니다.워크북을 저장하기 전에 저장합니다.

'requires reference to Microsoft Scripting Runtime
Function MkDir(strDir As String, strPath As String)

Dim fso As New FileSystemObject
Dim path As String

'examples of the input arguments
'strDir = "Folder"
'strPath = "C:\"

path = strPath & strDir

If Not fso.FolderExists(path) Then

' doesn't exist, so create the folder
          fso.CreateFolder path

End If

End Function

사용하지 않는 것이 좋습니다.Shell다양한 이유로 오류가 반환될 가능성이 있으므로 이에 대한 명령을 수행합니다.코드가 잘못된 오류를 무시하거나 무시합니다.

Microsoft 스크립팅 런타임에 대한 참조가 필요하지 않습니다.

Dim path_ As String
    path_ = "G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\" & .Range("H" & i) & "\KW " & .Range("A" & i)

Dim name_ As String
    name_ = file & " - " & file3 & " (" & file2 & ").xlsx"

With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(path_) Then .CreateFolder path_
End With

wbTemplate.SaveCopyAs Filename:=path_ & "\" & name_

OR

Dim path_ As String
    path_ = "G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\" & .Range("H" & i) & "\KW " & .Range("A" & i)

Dim name_ As String
    name_ = file & " - " & file3 & " (" & file2 & ").xlsx"

If Len(Dir(path_, vbDirectory)) = 0 Then MkDir path_

wbTemplate.SaveCopyAs Filename:=path_ & "\" & name_

이 매크로를 두 번 실행하여 확인 및 테스트합니다.

첫 번째 실행은 데스크톱에 "TEST"를 만들고 MsgBox "Making Directory!"를 만들어야 합니다.

두 번째 실행은 MsgBox "Dir Exists!"뿐이어야 합니다.

Sub mkdirtest()
Dim strFolderPath As String

strFolderPath = Environ("USERPROFILE") & "\Desktop\TEST\"
CheckDir (strFolderPath)

End Sub

Function CheckDir(Path As String)

    If Dir(Path, vbDirectory) = "" Then
        MkDir (Path)
        MsgBox "Making Directory!"
    'End If
    Else
        MsgBox "Dir Exists!"
    End If

End Function

오류 처리기를 사용할 수 있을 때 수동으로 확인할 필요가 있습니까?

On Error Resume Next
MkDir directoryname
On Error Goto 0

전체 경로가 존재하도록 하는 것이 다음과 같은 도움이 될 수 있습니다.

    '.
    '.
    DIM FSO as new Scripting.FilesystemObject
    '.
    '.
    Public Sub MkDirIfNotExist(strPath As String)
        If strPath = "" Then Err.Raise 53 'File not found e.g. Drive does not exists
        If Not FSO.FolderExists(strPath) Then
            MkDirIfNotExist FSO.GetParentFolderName(strPath)
            FSO.CreateFolder strPath
        End If
    End Sub

sub dosomethingwithfileifitexists()
If IsFile("filepathhere") = True Then
end if
end sub

Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
    On Error Resume Next
    IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function

이것은 제가 온라인에서 찾은 편리한 작은 기능입니다. 어디서 온 건지 기억이 안 나요!코드 작성자에게 사과합니다.

가장 간단하고 짧은 방법은 다음과 같습니다.

 'requires reference to Microsoft Scripting Runtime
    sub createDir(ByVal pathFolder As String)
    Dim fso As Object
    Dim path As String
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(pathFolder) Then
    ' doesn't exist, so create the folder
         fso.CreateFolder pathFolder
    End If

    Set fso = Nothing
    Application.ScreenUpdating = True
    End Sub

여기서 받아들여진 답을 읽고 시도해 본 결과, 효과가 없었습니다.그래서 저는 다음과 같은 기능을 쓰고, 테스트를 해보았는데 작동합니다.

늦은 바인딩을 사용하기 때문에 라이브러리 참조를 추가할 필요가 전혀 없습니다.

Function FolderCreate(ByVal strPathToFolder As String, ByVal strFolder As String) As Variant

'The function FolderCreate attemps to create the folder strFolder on the path strPathToFolder _
' and returns an array where the first element is a boolean indicating if the folder was created/already exists
' True meaning that the folder already exists or was successfully created, and False meaning that the folder _
' wans't created and doesn't exists
'
'The second element of the returned array is the Full Folder Path , meaning ex: "C:\MyExamplePath\MyCreatedFolder"

Dim fso As Object
'Dim fso As New FileSystemObject
Dim FullDirPath As String
Dim Length As Long

'Check if the path to folder string finishes by the path separator (ex: \) ,and if not add it
If Right(strPathToFolder, 1) <> Application.PathSeparator Then
    strPathToFolder = strPathToFolder & Application.PathSeparator
End If

'Check if the folder string starts by the path separator (ex: \) , and if it does remove it
If Left(strFolder, 1) = Application.PathSeparator Then
    Length = Len(strFolder) - 1
    strFolder = Right(strFolder, Length)
End If

FullDirPath = strPathToFolder & strFolder

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FolderExists(FullDirPath) Then
    FolderCreate = Array(True, FullDirPath)
Else
    On Error GoTo ErrorHandler
    fso.CreateFolder path:=FullDirPath
    FolderCreate = Array(True, FullDirPath)
    On Error GoTo 0
End If

SafeExit:
    Exit Function

ErrorHandler:
    MsgBox prompt:="A folder could not be created for the following path: " & FullDirPath & vbCrLf & _
            "Check the path name and try again."
    FolderCreate = Array(False, FullDirPath)

End Function

오류 처리 기능을 사용하여 이 작업을 수행할 수 있습니다.다음과 같은 것:

Sub subCreatesNewFolderIfThereIsNotExists(strFolderName As String)

On Error GoTo CaseFolderExists
    
    strFullPath = ThisWorkbook.path & "\" & strFolderName
    
    MkDir (strFullPath)

    Exit Sub


CaseFolderExists:
    ''' Do nothing
    
End Sub

언급URL : https://stackoverflow.com/questions/43658276/create-folder-path-if-does-not-exist-saving-from-vba