Create folder path if does not exist (saving issue

Question

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.

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

Answer 1

No reference to Microsoft Scripting Runtime required.

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_

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

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

Answer 3

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.

Answer 4

Run this Macro two times to confirm & test.

First run should create a direcotry "TEST" on desktop and MsgBox "Making Directory!".

Second run should just 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