VBA code to save a file in folder that changes each month and year

I need some code that will save a file to a folder that changes every month and Year.


folder path = G:\rights\Mkt\Break\2013\06 Jun

Next month it will be

folder path = G:\rights\Mkt\Break\2013\06 Jul

and next year

folder path = G:\rights\Mkt\Break\2014\06 Jun

Appreciate help provideing VBA code. I am using 2010

Who is Participating?
MichaelConnect With a Mentor Business AnalystCommented:
Or try this code, which also checks if a folder already exists, if not it creates it.
It assumes you want to save the current workbook, and that you want to save the file in the folder of the current month in the current year.
If not, you can replace now with the right date with "" around it.

Sub monthFolder()
    Dim sBasePath As String
    Dim sFilename As String
    Dim sMonth As String
    Dim sPath As String
    Dim sYear As String
    sFilename = "myWorkbook.xlsm" 'Set filename
    sBasePath = "C:\rights\Mkt\Break\" 'Set base path
    If Right(sBasePath, 1) <> "\" Then sBasePath = sBasePath & "\" 'Check for "\"
    sYear = Year(Now) 'Set this year
    sPath = sBasePath & sYear & "\" 'Set path incl. year
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath 'Create directory if it does not exist
    End If
    If Len(Month(Now)) = 1 Then
        sMonth = "0" & Month(Now) 'Add leading zero
        sMonth = Month(Now)
    End If
    sMonth = sMonth & " " & MonthName(Month(Now), True) 'Set month as number + name
    sPath = sPath & sMonth & "\" 'Set path incl. month
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath 'Create directory if it does not exist
    End If
    ActiveWorkbook.SaveAs sBasePath & sFilename
End Sub

Open in new window


What is 06 for?

if not relevant

 folderPath = "G:\rights\Mkt\Break\" & Year(Date) & "\06 " & Format(Date, "Mmm")

Open in new window

JagwarmanAuthor Commented:
oops it should have read:

Next month it will be

folder path = G:\rights\Mkt\Break\2013\07 Jul
JagwarmanAuthor Commented:
Below is the code I have used on other files but for some reason this fails with "Method 'Save As' of object'_Workbook' failed.....

Sub CreateFile()
Dim strFile As String
strFile = Date_FileName("\\G:\rights\Mkt\Break\2013\06 Jun\", "COB ")

If Dir(strFile) <> "" Then
   If MsgBox("File already exists - overwrite?", vbYesNo) = vbYes Then
      Kill strFile

      Exit Sub
   End If
End If

ActiveWorkbook.SaveAs Filename:= _
strFile, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

'MsgBox "File Created, close file"

End Sub

Function Date_FileName(pPath As String, pFilePrefix As String) As String
Dim DayOfWeek As Integer, DayDiff As Integer, CharDate As String, MonthNo As Integer, CharYear As String, CharMonth  As String
Dim Result As String
    DayOfWeek = Weekday(Date)                                   ' Sunday is 1, Monday is 2, Tuesday is 3 etc
    If DayOfWeek = 2 Then                                       ' If a monday then we need the date as of friday, otherwise previous day
        DayDiff = 3
        If DayOfWeek = 1 Then
          DayDiff = 2                                           ' If a Sunday then we need the date as of friday, otherwise previous day
          DayDiff = 1                                           ' otherwise it should be set to the previous day
        End If
    End If
    CharDate = Format(Date - DayDiff, "ddmmyyyy")               ' Get the character date formwatted how we want it

    CharMonth = Format(Date - DayDiff, "m mmm yyyy")
    Result = pPath & CharMonth & "\" & pFilePrefix & "" & CharDate & ".xls"
    Date_FileName = Result
End Function
JagwarmanAuthor Commented:
jazzyjoop, I will accept your solution as it works [although not for what I wanted this time, I will keep it on file] I sorted out my original piece of code and it now works.

All Courses

From novice to tech pro — start learning today.