'Create folder path if does not exist (saving from VBA)
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.
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
Solution 1:[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 of 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
it's better to avoid using Shell command for this as it is likely to return errors for various reasons. Your code even ignores/bypasses errors which is not wise.
Solution 2:[2]
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_
Solution 3:[3]
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
Solution 4:[4]
Why bother explicitly checking manually when one can use error handler:
On Error Resume Next
MkDir directoryname
On Error Goto 0
Solution 5:[5]
To ensure the whole path exists recursion may help:
'.
'.
DIM FSO as new Scripting.FilesystemObject
'.
'.
Public Sub MkDirIfNotExist(strPath As String)
If strPath = "" Then Err.Raise 53 'File not found e.g. Drive does not exists
If Not FSO.FolderExists(strPath) Then
MkDirIfNotExist FSO.GetParentFolderName(strPath)
FSO.CreateFolder strPath
End If
End Sub
Solution 6:[6]
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.
Solution 7:[7]
after reading the accepted answer here, and trying it, it didn't work. So I wrote the following function, tested it and it does work.
It doesn't require to add any library refence at all as it uses late binding
Function FolderCreate(ByVal strPathToFolder As String, ByVal strFolder As String) As Variant
'The function FolderCreate attemps to create the folder strFolder on the path strPathToFolder _
' and returns an array where the first element is a boolean indicating if the folder was created/already exists
' True meaning that the folder already exists or was successfully created, and False meaning that the folder _
' wans't created and doesn't exists
'
'The second element of the returned array is the Full Folder Path , meaning ex: "C:\MyExamplePath\MyCreatedFolder"
Dim fso As Object
'Dim fso As New FileSystemObject
Dim FullDirPath As String
Dim Length As Long
'Check if the path to folder string finishes by the path separator (ex: \) ,and if not add it
If Right(strPathToFolder, 1) <> Application.PathSeparator Then
strPathToFolder = strPathToFolder & Application.PathSeparator
End If
'Check if the folder string starts by the path separator (ex: \) , and if it does remove it
If Left(strFolder, 1) = Application.PathSeparator Then
Length = Len(strFolder) - 1
strFolder = Right(strFolder, Length)
End If
FullDirPath = strPathToFolder & strFolder
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FullDirPath) Then
FolderCreate = Array(True, FullDirPath)
Else
On Error GoTo ErrorHandler
fso.CreateFolder path:=FullDirPath
FolderCreate = Array(True, FullDirPath)
On Error GoTo 0
End If
SafeExit:
Exit Function
ErrorHandler:
MsgBox prompt:="A folder could not be created for the following path: " & FullDirPath & vbCrLf & _
"Check the path name and try again."
FolderCreate = Array(False, FullDirPath)
End Function
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | |
| Solution 2 | |
| Solution 3 | FreeSoftwareServers |
| Solution 4 | |
| Solution 5 | Merilix2 |
| Solution 6 | Lowpar |
| Solution 7 | David |