VBA to Save to folder of Current Year

[adavid]

The sub below saves each sheet in a workbook as a separate file to two different folders. How can I add a third folder if the folder structure is based on year?
i.e., I would need to save sheet one in the "Section 1" folder under "Blue Deck 2016"

Sub SaveWS_to_file()
'
'
' Created 9/28/2008 by Jeffrey A Slomka
'

Dim x As Integer, Name As String, Name2 As String, Name3 As String

On Error GoTo Error_Handler
For x = 1 To Sheets.Count
    
    Name = "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\"
    Name = Name & "EDW Crystal Reports (Automation)\Test files\Section "
    Name = Name & x & ".xls"
    Sheets("Section " & x).Copy
    ChDir "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\EDW Crystal Reports (Automation)\Test files"
    
    Name2 = "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\"
    Name = Name & "Section " & x & ".xls"
    Name = Name & x & ".xls"
    Sheets("Section " & x).Copy
    ChDir "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\"
    
    
    'Deletes file if it already exists
    On Error Resume Next
    Kill (Name)
    On Error GoTo Error_Handler
    
    ActiveWorkbook.SaveAs Filename:=Name, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
    ActiveWorkbook.SaveAs Filename:=Name2, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
    ActiveWindow.Close
Next x

Exit_Procedure:
    Exit Sub

Error_Handler:
    If Err.Number = 2501 Or 440 Then
        Resume Exit_Procedure
    Else
        MsgBox "An error has occurred in this application. " _
        & "Please contact your technical support person and " _
        & "tell them this information:" _
        & vbCrLf & vbCrLf & "Error Number " & Err.Number & ", " _
        & Err.Description, _
        Buttons:=vbCritical, Title:="DMT Error"
        Resume Exit_Procedure
        Resume
    End If
    Error [(errornumber)]


End Sub

 

[Joe4]

If you wanted wanted to return the phrase "Blue Deck" followed by the current year in VBA, it would look something like this:

"Blue Deck " & Year(Date)

 

[adavid]

So an IF statement or a CASE statement? How can I check the folder name with VBA?

If you wanted wanted to return the phrase "Blue Deck" followed by the current year in VBA, it would look something like this:

"Blue Deck " & Year(Date)

 

[Joe4]

You can run some VBA code to see if a folder exists. You can either do it right in the procedure, or create a Function to do it and call that function (that is helpful if you need to check multiple folder names).
See:
http://www.mrexcel.com/forum/excel-...irectory-excel-visual-basic-applications.html
and
Excel Checking if a directory exists

 

[adavid]

Thanks! I have the sub working to check the folder year, but what is the syntax to go a level lower and check the "section" folder it should save to?
For instance if the sheet name is Section 1, then it should save to the folder "Section 1 Jobs Released Last Week (excludes NRT Jobs)"

You can run some VBA code to see if a folder exists. You can either do it right in the procedure, or create a Function to do it and call that function (that is helpful if you need to check multiple folder names).
See:
http://www.mrexcel.com/forum/excel-...irectory-excel-visual-basic-applications.html
and
Excel Checking if a directory exists

 

[Joe4]

Not quite sure I follow...

Can you post a complete example, with complete folder/file names, and maybe your relevant section of updated code?

 

[adavid]

These are the destination folders:


This code locates the folder a level above the folders in the image above. (Blue Deck 2016)

Sub folCheck()
 Dim fName As String

    fName = "\\marnv006\Bm\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\Blue Deck\Blue Deck "
    fName = fName & Year(Date)
    
 If Dir(fName, vbDirectory) <> "" Then
   If Dir(fName, vbDirectory) <> "" Then
        MsgBox "This folder is already here"
    Else
        MsgBox "No, path does not exist."
    End If

End Sub

The sheets in the wor book are named Section 1, Section 2, Section 3, etc. How can I add in a step that saves each Sheet into the respective folders.

Not quite sure I follow...

Can you post a complete example, with complete folder/file names, and maybe your relevant section of updated code?

 

[Joe4]

I cannot see that image you tried to post.
But you should be able to continue to build the foldernames you need, i.e.

fname1 = fname & "\Section 1"
fname2 = fname & "\Section 2"
fname3 = fname & "\Section 3"

Is that what you are looking for?
If not, please explain exactly what part is tripping you up?

 

[adavid]

Thank you. Your suggestion helps, but how do I direct the appropriate sheet to the appropriate folder? With the SaveWS_to_file Sub below it uses the sheet number, but saves all the sheets in one folder. I need to save each sheet into its respective folder; i.e., Section 1 sheet (Sheet1) needs to go into the Section 1 folder.

Sub SaveWS_to_file()

Dim x As Integer, Name As String, Name2 As String, Name3 As String, fName As String

On Error GoTo Error_Handler
For x = 1 To Sheets.Count
    
    Name = "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\"
    Name = Name & "EDW Crystal Reports (Automation)\Test files\Section "
    Name = Name & x & ".xls"
    Sheets("Section " & x).Copy
    ChDir "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\EDW Crystal Reports (Automation)\Test files"
    
    Name2 = "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\"
    Name = Name & "Section " & x & ".xls"
    Name = Name & x & ".xls"
    Sheets("Section " & x).Copy
    ChDir "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\"
    
    fName = "\\marnv006\Bm\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\Blue Deck\Blue Deck "
    fName = fName & Year(Date)
    
    'Deletes file if it already exists
    On Error Resume Next
    Kill (Name)
    On Error GoTo Error_Handler
    
    ActiveWorkbook.SaveAs Filename:=Name, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
    ActiveWorkbook.SaveAs Filename:=Name2, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        

        
    ActiveWindow.Close
Next x

Exit_Procedure:
    Exit Sub

Error_Handler:
    If Err.Number = 2501 Or 440 Then
        Resume Exit_Procedure
    Else
        MsgBox "An error has occurred in this application. " _
        & "Please contact your technical support person and " _
        & "tell them this information:" _
        & vbCrLf & vbCrLf & "Error Number " & Err.Number & ", " _
        & Err.Description, _
        Buttons:=vbCritical, Title:="DMT Error"
        Resume Exit_Procedure
        Resume
    End If
    Error [(errornumber)]


End Sub

I cannot see that image you tried to post.
But you should be able to continue to build the foldernames you need, i.e.

fname1 = fname & "\Section 1"
fname2 = fname & "\Section 2"
fname3 = fname & "\Section 3"

Is that what you are looking for?
If not, please explain exactly what part is tripping you up?

 

[Joe4]

I have always copied the sheet I want to save to a new file, and then save that, so that it doesn't save all the other sheets along with it.
But it looks like there are a few other ways to do it, as shown here:
https://www.extendoffice.com/documents/excel/785-excel-save-export-sheet-as-new-workbook.html