创建文件夹路径（如果不存在）（保存问题）

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

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\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

3 个解决方案

#1

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 Shell command for this as it is likely to return error. Your code even ignores errors which is not wise.

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

#2

No reference to Microsoft Scripting Runtime required.

不需要参考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_)) = 0 Then MkDir path_

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

#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

This is a handy little function I found online, I cannot remember where it is from! Apologise to the autor of the code.

这是我在网上找到的一个方便的小功能，我不记得它来自哪里！向代码的autor道歉。

#1