vba 如果不存在则创建文件夹路径（保存问题）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/43658276/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Create folder path if does not exist (saving issue)
提问by user7415328
I have a list of items in a sheet like so:
我在工作表中有一个项目列表，如下所示：
My code goes through each row and groups the supplier and copies some information into a work book for each supplier.
我的代码遍历每一行并将供应商分组，并将一些信息复制到每个供应商的工作簿中。
in this scenario there are 2 unique suppliers, so 2 workbooks will be created.
在此方案中，有 2 个唯一供应商，因此将创建 2 个工作簿。
This works.
这有效。
Next i want to save each workbook in a specific folder path. If the folder path does not exist then it should be created.
接下来我想将每个工作簿保存在特定的文件夹路径中。如果文件夹路径不存在，则应该创建它。
Here's the piece of code for this bit:
这是该位的一段代码：
'Check directort and save
Path = "G:\BUYING\Food Specials. 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"
For some reason, both workbooks are saved if the directory exists, but only one workbook is saved if the directory doesn't exist and has to be created.
出于某种原因，如果目录存在，则两个工作簿都会保存，但如果目录不存在且必须创建，则仅保存一个工作簿。
Please can someone show me where i am going wrong? Thanks in advance
请有人告诉我我哪里出错了？提前致谢
Full Code:
完整代码：
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. 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. 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
回答by M--
You need to check if the folder exists. If not, then make it. This function does the job. Place it before saving your workbook.
您需要检查文件夹是否存在。如果没有，那就去做吧。这个功能完成了这项工作。在保存工作簿之前放置它。
'requires reference to Microsoft Scripting Runtime
Function MkDir(strDir As String, strPath As String)
Dim fso As New FileSystemObject
Dim path As String
'examples for what are 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
p.s. This is not tested as I am right now on my phone. But it's better to avoid using Shellcommand for this as it is likely to return error. Your code even ignores errors which is not wise.
ps 这没有经过测试，因为我现在在我的手机上。但是最好避免Shell为此使用命令，因为它可能会返回错误。您的代码甚至会忽略不明智的错误。
回答by Kostas K.
No reference to Microsoft Scripting Runtime required.
无需参考 Microsoft Scripting Runtime。
Dim path_ As String
path_ = "G:\BUYING\Food Specials. 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. 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_)) = 0 Then MkDir path_
wbTemplate.SaveCopyAs Filename:=path_ & "\" & name_
回答by Jorge Martins
Run this Macro two times to confirm & test.
运行此宏两次以确认和测试。
First run should create a direcotry "TEST" on desktop and MsgBox "Making Directory!".
第一次运行应该在桌面上创建一个目录“TEST”和 MsgBox“制作目录！”。
Second run should just MsgBox "Dir Exists!"
第二次运行应该只是 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
回答by Lowpar
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
This is a handy little function I found online, I cannot remember where it is from! Apologise to the autor of the code.
这是我在网上找到的一个方便的小功能，我不记得它是从哪里来的！向代码的作者道歉。
