如果不存在，创建文件夹路径（从VBA保存）

Question

如果不存在，创建文件夹路径（从VBA保存）

excelvba

22

我有一个像这样的表格中的项目列表：

我的代码遍历每一行并对供应商进行分组，将一些信息复制到每个供应商的工作簿中。在这种情况下有两个唯一的供应商，因此将创建两个工作簿。这很有效。

接下来，我想将每个工作簿保存在特定的文件夹路径中。如果文件夹路径不存在，则应创建该路径。

这是代码片段：

'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

- user7415328

2

如果你注释掉了你的"On Error Resume Next"，你会得到一个错误吗？你应该非常小心地使用这个语句，并尽可能短的时间。要关闭这种模式，你可以添加"On Error Goto 0"。 - Rich Holton

可能是[检查目标目录是否存在，如果不存在则创建并继续进行VBA]的重复问题(https://dev59.com/JH3aa4cB1Zd3GeqPdng6)。 - Wayne Phipps

9个回答

36

不需要引用Microsoft Scripting Runtime。

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_

或者

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_

- Kostas K.

2

喜欢这个：If Len(Dir(path_)) = 0 Then MkDir path_ - Sean McCarthy

1

如果 Len(Dir(path_)) = 0，则表示检查一个字符串是否存在，而不是一个文件对象。我认为需要创建一个目录，则执行 MkDir path_。 - Timo

1

@Timo 确实如此，但不是任何字符串，而是从 Dir() 函数返回的目录字符串。 - Kostas K.

6

如果文件夹为空，我认为需要添加vbDirectory参数：If Len(Dir(path_, vbDirectory)) = 0 Then MkDir path_ - olly

9

运行此宏两次以确认和测试。

第一次运行应在桌面上创建一个名为“TEST”的目录，并弹出消息框“正在创建目录！”。

第二次运行应只弹出消息框“目录已存在！”

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

- Jorge Martins

希望你不介意我在顶部添加了一个测试子程序 :)Translated text: 希望你不介意我在顶部添加了一个测试子程序 :) - FreeSoftwareServers

3

为什么要手动明确检查，当可以使用错误处理程序：

On Error Resume Next
MkDir directoryname
On Error Goto 0

- Dmitry Ishutin

1

明确检查文件夹可以清楚地表明意图。像这样使用错误处理程序不仅会导致代码不清晰，有时还会错过实际错误的原因。 - KalenGi

2

为确保整个路径存在，可以使用递归：

    '.
    '.
    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

- Merilix2

1

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

我在网上找到了这个方便的小函数，但我不记得它来自哪里！向代码的作者道歉。

- Lowpar

2

不用谢;-) 但在这种情况下，OP最好使用它的姐妹函数IsFolder。 - iDevlop

0

在阅读了这里的被接受答案并尝试后，它并没有起作用。因此我编写了以下函数，测试过它可以工作。

它不需要添加任何库引用，因为它使用了后期绑定。

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

- David

0

这是最简单和最短的方法：

 '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

- Noam Brand

-1

你可以使用错误处理函数来实现。类似这样：

Sub subCreatesNewFolderIfThereIsNotExists(strFolderName As String)

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

    Exit Sub


CaseFolderExists:
    ''' Do nothing
    
End Sub

- claudius

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- M-- · Accepted Answer

你需要检查文件夹是否存在。如果不存在，就创建一个。这个函数可以完成这个任务。在保存工作簿之前放置它。

'requires reference to Microsoft Scripting Runtime
Function Mk_Dir(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命令，因为它很可能因各种原因返回错误。你的代码甚至忽略/绕过错误，这是不明智的。