Save File in New Created Folder

[Nick72310]

I am trying to save a file in a folder using macro, but I want to create a new folder if the folder does not already exist. If it does exist, I want it to save in the proper folder.

The folder names are based off of the date... In my spreadsheet I have code that generates todays date when the document is opened. I want the new created folders to be the year, followed by the word Quotes (ie. 2016 Quotes). So throughout the year of 2016, I want all the files to be saved in folder 2016 Quotes. But as soon as 2017 comes around, I want a new folder to automatically be created (2017 Quotes) and the file should be saved there.

The file name is based off of the value in "Sheets("BOM & Routing (IE)").Range("N3")". (This cell is formatted as Text)

The directory is based off of the date in "Sheets("BOM & Routing (IE)").Range("G5")". Where G5 is the date in the format of "mm/dd/yy". But I only want the year to be present in the folder name.

My code is shown below. I have also attached a file to make it easier. The sheet is password protected. The password is IE.
Thank you in advance!

15122


Sub Auto_open()
On Error Resume Next
With Worksheets("BOM & Routing (IE)")
.Unprotect Password:="IE"
.Protect Password:="IE", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
userInterfaceOnly:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=True, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=True, _
AllowSorting:=False, _
AllowFiltering:=False, _
AllowUsingPivotTables:=False
With .Range("G5")
If IsEmpty(.Value) Then
.Value = Date
.NumberFormat = "mm/dd/yy"
End If
End With
Application.Goto .Range("G4")
End With
End Sub




Function DirectoryExist(sstr As String)
Dim lngAttr As Long
DirectoryExist = False
If Dir(sstr, vbDirectory) <> "" Then
lngAttr = GetAttr(sstr)
If lngAttr And vbDirectory Then _
DirectoryExist = True
End If
End Function
Sub Test()
Dim dirstr As String
dirstr = "C:\Users\Nick72310\Desktop\" & Sheets("BOM & Routing (IE)").Range("G5").Value & " Quotes"
If Not DirectoryExist(dirstr) Then
MkDir dirstr
ActiveWorkbook.SaveAs _
dirstr & Sheets("BOM & Routing (IE)").Range("N3") & ".xlsm", FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else
ActiveWorkbook.SaveAs Filename:= _
dirstr & Sheets("BOM & Routing (IE)").Range("N3") & ".xlsm", FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If

End Sub

[GTO]

Greetings Nick,

After running the Auto_Open, select G5. Notice that in the formula bar, the Value of G5 is (by today's date): 1/8/2016, and this results in dirstr returning: "C:\Users\Nick72310\Desktop\1/8/2016 Quotes"

So the formatting of the cell only changes the format (the looks if you will). Anyways, if you only are looking to return the current year, maybe try:

dirstr = "C:\Users\Nick72310\Desktop\" & Year(Date) & " Quotes"
...which will return: C:\Users\Nick72310\Desktop\2016 Quotes

Does that help?

Mark

[Nick72310]

Thank you GTO, but I tried your code and it did not create a folder. If possible, I would like the year to be dependent on the date in cell G5. Not necessarily the year of the actual date.

Also, my code to actually save the file in a folder does not work. So that needs improving as well.

[GTO]

I didn't test it through, but I think you are missing a separator in the saveas bit. As far as creating the folder:



Option Explicit

Declare Function lstrlen Lib "kernel32" _
Alias "lstrlenA" (ByVal lpString As Any _
) As Long

Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long _
) As Long

Public Function RetUserName() As String
Dim lpUserName As String * 255

If CBool(GetUserName(lpUserName, 255)) Then
RetUserName = Left$(lpUserName, lstrlen(lpUserName))
Else
RetUserName = vbNullString
End If

End Function

Function DirectoryExist(sstr As String) As Boolean
Dim lngAttr As Long
DirectoryExist = False

If Dir(sstr, vbDirectory) <> "" Then
lngAttr = GetAttr(sstr)
End If

If lngAttr And vbDirectory Then
DirectoryExist = True
End If

End Function

Hope that helps,

Mark

[Nick72310]

I cannot seem to get it to work.

[Nick72310]

I have everything working except for having the folder name be dependent on the manual date (just including the year).

15141


Function DirectoryExist(sstr As String)
Dim lngAttr As Long
DirectoryExist = False
If Dir(sstr, vbDirectory) <> "" Then
lngAttr = GetAttr(sstr)
If lngAttr And vbDirectory Then _
DirectoryExist = True
End If
End Function
Sub Test()
Dim dirstr As String
'dirstr = "C:\Users\Nick72310\Desktop\" & Year(Date) & " Quotes\"
dirstr = "C:\Users\Nick72310\Desktop\" & Worksheets("BOM & Routing (IE)").Range("G5").Value & " Quotes\"
If Not DirectoryExist(dirstr) Then
MkDir dirstr
ActiveWorkbook.SaveAs _
dirstr & Sheets("BOM & Routing (IE)").Range("N2") & ".xlsm", FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else
ActiveWorkbook.SaveAs Filename:= _
dirstr & Sheets("BOM & Routing (IE)").Range("N2") & ".xlsm", FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If

End Sub

[Kenneth Hobs]

dirstr = "C:\Users\Nick72310\Desktop\" & Format(Worksheets("BOM & Routing (IE)").Range("G5").Value, "yyyy") & " Quotes\"
Of course it could be coded to lookup your desktop path as well.

[Nick72310]

Genius Kenneth! Thank you!

Thank you GTO for your effort as well.