vba如果文件夹path不存在然后创build（保存问题）

我有一个表中的项目列表，如下所示：

我的代码遍历每一行并将供应商分组，并将一些信息复制到每个供应商的工作簿中。

在这种情况下有2个独特的供应商，所以将创build2个工作簿。

这工作。

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

这是这一点的代码片段：

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

由于某些原因，如果该目录存在，两个工作簿都将被保存，但如果该目录不存在并且必须创build，则只会保存一个工作簿。

请有人告诉我我要去哪里错了吗？ 提前致谢

完整代码：

 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 

Answer 1

你需要检查文件夹是否存在。 如果没有，那么就做吧。 这个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 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 

ps这是没有testing，因为我现在在我的手机上。 但最好避免使用Shell命令，因为它可能会返回错误。 你的代码甚至会忽略不明智的错误。

Answer 2

不需要引用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_ 

要么

 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_)) = 0 Then MkDir path_ wbTemplate.SaveCopyAs Filename:=path_ & "\" & name_ 

Answer 3

 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 

这是我在网上find的一个方便的小function，我不记得它来自哪里！ 道歉的代码的作者。