# Solved: Excel 2010 - Macro to name and save file to a specific folder



## Tekon (May 10, 2013)

Hello all. Not a regular user of Excel; but do need help in creating something that would be useful to me and a few others at work. I suppose the best way of explaining what I'm after is by giving an example.

I have a directory C:\Users\Tekko\Desktop\Maintenance Project\Cape Nelson
In Cape Nelson are a number of folders named alpha beta charlie delta echo and foxtrot and so on.

I would like to have an excel template in "Cape Nelson" with a macro that when activated names the file as whatever folder name might be in say cell A1 and whatever ever date might be in cell B1. Eg charlie_15-mar-2013.xls

This then is saved in the relevant folder. So in the end I would end up with 
C:\Users\Tekko\Desktop\Maintenance Project\Cape Nelson\charlie\charlie_15-mar-2013.xls

Also the macro script would ensure that the macro was disabled in the saved file.

Hoping this is achievable and look forward to replies.


----------



## XCubed (Feb 22, 2013)

Hi

Attached is an example of saving a copy of a file to another directory that will strip out the macros in the new file

It will copy only the current spreadsheet of the template. If you need more this can be done.

Test this out in your environment changing the name and date in the template several times as it may occur in the "real world" and let me know how that goes.


----------



## Tekon (May 10, 2013)

Thank you very much XCubed for your help.

This file worked exactly as I was looking for. It's going to make my project a lot easier to operate. 

One further question. Is it possible to somehow protect the macro so that other users who come along cannot inadvertently lose it or alter it in any way?

Edit: Sorry XCubed. Did a bit of searching and found the solution to protecting the macro


----------



## XCubed (Feb 22, 2013)

hi

i'm glad it works for you. To protect the code;


in Visual Basic click on Tools/VBAProject Properties
In the pop-up click on the Protection tab
Fill in required information
Save the workbook/close it/re-open it and test that the VBA is protected (double click on Module1)
Don't forget your password


----------



## XCubed (Feb 22, 2013)

Hi Tekon

I found a bug in my code whereby the Button was not deleted in the new file. This version fixes that.

I also added in a check to see if the new file is already open (in the scenario where a user opens the file to check it, finds an error and goes back to the template to fix the problem and regenerate the file). If it is open the user will be prompted to either abort or close the file.


```
Sub SaveToDir2()
'
Dim wbk As Workbook
'
CDir = ActiveWorkbook.Path
'
SaveDir = CDir & "\" & ActiveSheet.Range("A1")
'
'check to see if Dir exists if not create it. Could also abort if the Dir should exist
If Len(Dir(SaveDir, vbDirectory)) = 0 Then
   MkDir SaveDir
End If
'
'Checks to see if the Date cell is in date format
If IsDate(ActiveSheet.Range("B1")) Then
    SaveName = ActiveSheet.Range("A1") & "_" & Application.Text(ActiveSheet.Range("B1"), "DD-MMM-YYYY") & ".xlsx"
Else
    SaveName = ActiveSheet.Range("A1") & "_" & ActiveSheet.Range("B1") & ".xlsx"
End If
'
'Check to see if the file already exists
    If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then
        Resp = MsgBox("File name:   " & SaveName & vbCrLf & vbCrLf & "already exists in:  " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
            If Resp = vbCancel Then
                Exit Sub
            End If
'           Check to see if the file is open
            For Each wbk In Workbooks
                If wbk.Name = SaveName Then
                    Resp2 = MsgBox(SaveName & " is open. Press OK to close the file or Cancel to abort", vbOKCancel)
                        If Resp2 = vbOK Then
                            Application.DisplayAlerts = False
                            Workbooks(SaveName).Close
                        Else
                            Exit Sub
                        End If
                End If
            Next
    End If
'
Application.DisplayAlerts = False
'
    Sheets("Sheet1").Copy                 'Moves Sheet1 only to a new file
    ActiveSheet.Shapes("Button 1").Cut    'cut out the button in the new file
    ActiveWorkbook.SaveAs Filename:= _
        SaveDir & "\" & SaveName, FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False    'Saves the new file
'
    ActiveWindow.Close
'
MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)
'
Application.DisplayAlerts = True
 
End Sub
```


----------



## Tekon (May 10, 2013)

Hi again Xcubed.

I hadn't realised you had posted again with more coding (thank you). And I only came back to this thread because I was having difficulty saving the the file if it had protection on it.

I had modified your original coding slightly to more suit the cell placements that were in my worksheet (see code below). And everything was working okay; didn't spot the button not being removed in saved files, or at least didn't worry too much about it.

Anyway, when I tried to lock cells that I didn't want other users fiddling with and then protected the worksheet, the save feature wouldn't work for me. I got run-time error '-2147024809(80070057) "The specified value is out of range"
When I selected debug it came to " ActiveSheet.Shapes("Button 1").Cut ". anything beyond that is out of my league.

Would the fix you posted back with alleviate this saving the protected sheet problem I'm having and if so is it possible you could put this fix into my coding? I find this coding very difficult and I don't want to really stuff anything up.

Many thanks,

Tekon.


```
Public Sub SaveToDir()

CDir = ActiveWorkbook.Path

SaveDir = CDir & "\" & ActiveSheet.Range("AB1")
'
'check to see if Dir exists if not create it. Could also abort if the Dir should exist
If Len(Dir(SaveDir, vbDirectory)) = 0 Then
   MkDir SaveDir
End If
'
'Checks to see if the Date cell is in date format
If IsDate(ActiveSheet.Range("B2")) Then
    SaveName = Application.Text(ActiveSheet.Range("B2"), "YYYY-MM-DD") & "_" & ActiveSheet.Range("AB1") & ".xlsx"
    
Else
    SaveName = ActiveSheet.Range("B2") & "_" & ActiveSheet.Range("AB1") & ".xlsx"
End If
'
'Check to see if the file already exists

If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then
    Resp = MsgBox("File name:   " & SaveName & vbCrLf & vbCrLf & "already exists in:  " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
End If
'

If Resp = vbCancel Then
    Exit Sub
End If

Application.DisplayAlerts = False

    Sheets("Cape Nelson").Copy
    ActiveWorkbook.SaveAs Filename:= _
        SaveDir & "\" & SaveName, FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False
    
    ActiveSheet.Shapes("Button 1").Cut
    
    
    ActiveWindow.Close
    
MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)

        
999   End Sub
```


----------



## XCubed (Feb 22, 2013)

Hi tekon

Which sheet is protected? or do you want both (the original and the new file you are creating). The macro should still run - there is nothing we are doing to the original file that would be contrary to the protection.

Perhaps it has something to do with the original bug I had found. At any rate here is the new Macro again with your changes incorporated.

Let me know if this is okay


```
Public Sub SaveToDir()
'
Dim wbk As Workbook
'
CDir = ActiveWorkbook.Path
'
SaveDir = CDir & "\" & ActiveSheet.Range("A1")
'
'check to see if Dir exists if not create it. Could also abort if the Dir should exist
If Len(Dir(SaveDir, vbDirectory)) = 0 Then
   MkDir SaveDir
End If
'
'Checks to see if the Date cell is in date format
If IsDate(ActiveSheet.Range("B1")) Then
    SaveName = ActiveSheet.Range("A1") & "_" & Application.Text(ActiveSheet.Range("B1"), "DD-MMM-YYYY") & ".xlsx"
    
Else
    SaveName = ActiveSheet.Range("A1") & "_" & ActiveSheet.Range("B1") & ".xlsx"
End If
'
'Check to see if the file already exists
    If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then
        Resp = MsgBox("File name:   " & SaveName & vbCrLf & vbCrLf & "already exists in:  " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
    End If
'
            If Resp = vbCancel Then
                Exit Sub
            Else
'           Check to see if the file is open
            For Each wbk In Workbooks
                If wbk.Name = SaveName Then
                    Resp2 = MsgBox(SaveName & " is open. Press OK to close the file or Cancel to abort", vbOKCancel)
                        If Resp2 = vbOK Then
                            Application.DisplayAlerts = False
                            Workbooks(SaveName).Close
                        Else
                            Exit Sub
                        End If
                End If
            Next
    End If
'
Application.DisplayAlerts = False
'
    Sheets("Cape Nelson").Copy                 'Moves Sheet1 only to a new file
    ActiveSheet.Shapes("Button 1").Cut    'cut out the button in the new file
    ActiveWorkbook.SaveAs Filename:= _
        SaveDir & "\" & SaveName, FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False    'Saves the new file
'
    ActiveWindow.Close
'
    MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)
        
'
Application.DisplayAlerts = True
        
End Sub
```


----------



## Tekon (May 10, 2013)

Tried using the new code and during the run I get - run time error '52' Bad file name or error.
Pressed debug which brought me to

If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then

That's about as far as I can get as I don't really understand this coding stuff. Below is the code with my mods in there.


```
Public Sub SaveToDir()
'
Dim wbk As Workbook
'
CDir = ActiveWorkbook.Path
'
SaveDir = CDir & "\" & ActiveSheet.Range("A1")
'
'check to see if Dir exists if not create it. Could also abort if the Dir should exist
If Len(Dir(SaveDir, vbDirectory)) = 0 Then
   MkDir SaveDir
End If
'
'Checks to see if the Date cell is in date format
If IsDate(ActiveSheet.Range("B2")) Then
    SaveName = Application.Text(ActiveSheet.Range("B2"), "YYYY-MMM-DD") & "_" & ActiveSheet.Range("AB1") & ".xlsx"
               
               Else
    SaveName = ActiveSheet.Range("B2") & "_" & ActiveSheet.Range("AB1") & ".xlsx"
End If
'
'Check to see if the file already exists
    If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then
        Resp = MsgBox("File name:   " & SaveName & vbCrLf & vbCrLf & "already exists in:  " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
    End If
'
            If Resp = vbCancel Then
                Exit Sub
            Else
'           Check to see if the file is open
            For Each wbk In Workbooks
                If wbk.Name = SaveName Then
                    Resp2 = MsgBox(SaveName & " is open. Press OK to close the file or Cancel to abort", vbOKCancel)
                        If Resp2 = vbOK Then
                            Application.DisplayAlerts = False
                            Workbooks(SaveName).Close
                        Else
                            Exit Sub
                        End If
                End If
            Next
    End If
'
Application.DisplayAlerts = False
'
    Sheets("Cape Nelson").Copy                 'Moves Sheet1 only to a new file
    ActiveSheet.Shapes("Button 1").Cut    'cut out the button in the new file
    ActiveWorkbook.SaveAs Filename:= _
        SaveDir & "\" & SaveName, FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False    'Saves the new file
'
    ActiveWindow.Close
'
    MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)
        
'
Application.DisplayAlerts = True
        
End Sub
```
Edit: Only want to protect the original. Save from anyone trying to change my formatting around.


----------



## XCubed (Feb 22, 2013)

I think I see the problem. The crucial operation is to change the date to a format that is acceptable as a file name i.e. you cannot have a "\" character in a file name. I believe that in all the switching around this was not being done and resulted in your error message.

The 2 cells on which you are basing the directory name and the file name are in

B2 and AB1

The code assumes that B2 will be text and AB1 is a date e.g.

B2 is Version1 
AB1 is 16/05/2013

This will result in 
Directory name will be "Version1"
File name will be "Verson1_2013-May-16"

If this is what you want this code will do that. If not, can you give an example of what is in B2 and AB1 and examples of what you want for the directory name and the file name and then I can adjust the code accordingly.


```
Public Sub SaveToDir()
'
Dim wbk As Workbook
'
CDir = ActiveWorkbook.Path
nDir = "B2"      'This cell contains the value that will be the new directory name and the first part of the file name
nDate = "AB1"    'This cell contains the date which will be the second part of the file name
'
SaveDir = CDir & "\" & ActiveSheet.Range(nDir)
'
'check to see if Dir exists if not create it. Could also abort if the Dir should exist
If Len(Dir(SaveDir, vbDirectory)) = 0 Then
   MkDir SaveDir
End If
'
'Checks to see if the Date cell is in date format
If IsDate(ActiveSheet.Range(nDate)) Then
    SaveName = Range(nDir) & "_" & Application.Text(ActiveSheet.Range(nDate), "YYYY-MMM-DD") & ".xlsx"
End If
If InStr(1, SaveName, "/") > 0 Then
    MsgBox ("Cell " & nDate & " is not a valid date. Please amend and re-run the copy")
    Exit Sub
End If
'
'Check to see if the file already exists
    If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then
        Resp = MsgBox("File name:   " & SaveName & vbCrLf & vbCrLf & "already exists in:  " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
    End If
'
            If Resp = vbCancel Then
                Exit Sub
            Else
'           Check to see if the file is open
                For Each wbk In Workbooks
                    If wbk.Name = SaveName Then
                        Resp2 = MsgBox(SaveName & " is open. Press OK to close the file or Cancel to abort", vbOKCancel)
                            If Resp2 = vbOK Then
                                Application.DisplayAlerts = False
                                Workbooks(SaveName).Close
                            Else
                                Exit Sub
                            End If
                    End If
                Next
            End If
'
Application.DisplayAlerts = False
'
    Sheets("Cape Nelson").Copy                 'Moves Sheet1 only to a new file
    ActiveSheet.Shapes("Button 1").Cut    'cut out the button in the new file
    ActiveWorkbook.SaveAs Filename:= _
        SaveDir & "\" & SaveName, FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False    'Saves the new file
'
    ActiveWindow.Close
'
    MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)
 
'
Application.DisplayAlerts = True
 
End Sub
```


----------



## Tekon (May 10, 2013)

Hi once again XCubed,

The directory name is in AB1 and the date is in B2. Then I'm trying to save the file in the selected directory with its file name as date and directory name. eg _2013-05-17_AC Lighting.xls_ . That's why I've turned it around in your coding. I wanted the date first so that when there are a few files in folder 'AC Lighting' they are numerically ordered so easier to look for any specific file based on date.

I've attached the file that I'm working on so it might be easier to follow what I'm talking about.

From this you can see I've got a few text boxes and combo boxes. The date is in cell B2 which is formatted DD-MMM-YY, easier for my colleagues to enter. In the running of the macro I changed this to YYYY-MM-DD. This worked okay.

One of the combo boxes is a list of equipment we do maintenance on. I.e. our directory list. The combo box is linked to AB1 (well out of the way so users don't see it).

The macro in this file is based on your original. Works fine. But does not as you pointed out delete the button. Also when I protect the worksheet the macro will not run to completion.

I have to say again Xcubed, I really appreciate the help you are giving me. There is no way I could get this done on my own.

Edit: Just read my original post so I see the confusion in the date system. I changed it around later so would list easier in the directory.


----------



## XCubed (Feb 22, 2013)

No worries - us Aussies have got to stick together (I live in NSW).

Question - when the sheet is protected don't you get an error message when you try to change the Equipment value in the combo box?

Still working on the main issue....


----------



## Tekon (May 10, 2013)

XCubed said:


> Question - when the sheet is protected don't you get an error message when you try to change the Equipment value in the combo box?


Before I protected the sheet I unlocked cell AB1. So no, did not get an error message.


----------



## XCubed (Feb 22, 2013)

Hi Tekon

When we copy the sheet from the Master it also copies the protected status to the new sheet we create so when we try to delete the button it won't let us.

There are 2 ways to get around this

1. Unprotect the sheet in the macro. To do this we have to hardcode the password into the macro - not a great thing to do however you are planning to hide the macros so it's not too bad. However, every time you change the password you will also have to change it in the macro. If you mistype the password (believing that you put in the regular password) the macro will fail.

2. When you protect the sheet (first time only) tick the box "Edit Objects" in the list o tings that are allowed. A malicious user will be able to delete the button and combo boxes but it would have to be a user well versed in Excel development. I think the risks are low.

Its up to you. I've set it up for the 1st option with password = tekon. You can obviously change that.

A couple of other things ....

Instead of putting the Equipment selection in AB1 we can get that value directly from the combo box. This eliminates the need to lock/unlock AB1.

I've also set up a DataBase file for you that will record each entry into a single workbook. This would be much more convenient than trolling through a multitude of folders and files to determine what has been entered. I've only set up the bare bones of it but if you don't like it or need it you can comment out or delete the line 

DBAddRec

near the bottom of the SaveToDir macro. The DB file is called CapeNelsonDB.xlsx and should reside in the same folder as the Recorder file.

The files are attached


----------



## Tekon (May 10, 2013)

XCubed said:


> I've also set up a DataBase file for you that will record each entry into a single workbook. This would be much more convenient than trolling through a multitude of folders and files to determine what has been entered. I've only set up the bare bones of it but if you don't like it or need it you can comment out or delete the line
> 
> DBAddRec
> 
> near the bottom of the SaveToDir macro. The DB file is called CapeNelsonDB.xlsx and should reside in the same folder as the Recorder file.


Coincidently one of the guys I work with was asking me if anything like this could be done and I was going to look into it after getting the first problem solved. Thanks to you it's all done.

Both the files are perfect. I'll definitely be acknowledging your help when we get this system rolling.

If you're ever in Portland drop into the tugboat berth on main breakwater, ask for Tekko. I'll be happy to show you around the tugs. And again thank you.


----------



## XCubed (Feb 22, 2013)

You're very welcome and thank you or the invitation. As I said, though, the DB file routine is bare bones. The hurdle to overcome with it is the potential of multiple users on it at the same time This may be overcome by making it a shared workbook. 

See how it goes and if you hit any roadblocks you know where to go or help.


----------

