VBA如果文件夾路徑不存在，則創建（保存期）

Question

我有一個項目清單中的紙張，像這樣：

我的代碼經過每一行和每一組的供應商，並複製一些信息寫入每個供應商的工作簿。

在這種情況下有2個獨特的供應商，所以將創建2個工作簿。

This Works。

接下來我想將每個工作簿保存在特定的文件夾路徑中。 如果文件夾路徑不存在，那麼它應該被創建。

下面是該位的一段代碼：

'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 

Answer 1

您需要檢查，如果該文件夾存在。如果不是，那就製作它。這個功能完成這項工作。在保存工作簿之前放置它。

'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.這是沒有測試，因爲我現在在我的手機上。但最好避免使用Shell命令，因爲它可能會返回錯誤。你的代碼甚至會忽略不明智的錯誤。

Answer 2

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 

這是我在網上找到的一個方便的小功能，我不記得它來自哪裏！道歉的代碼的作者。

Answer 3

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

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_)) = 0 Then MkDir path_ 

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