1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

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

Discussion in 'Business Applications' started by Tekon, May 10, 2013.

Thread Status:
Not open for further replies.
Advertisement
  1. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    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.
     
  2. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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.
     

    Attached Files:

  3. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    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
     
  4. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    hi

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

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

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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.

    Code:
    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
     
  6. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    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.


    Code:
    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
    
     
  7. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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

    Code:
    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
    
     
  8. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    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.

    Code:
    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.
     
  9. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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.



    Code:
    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
    
     
  10. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    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.
     

    Attached Files:

  11. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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....
     
  12. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    Before I protected the sheet I unlocked cell AB1. So no, did not get an error message.
     
  13. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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
     

    Attached Files:

  14. Tekon

    Tekon Thread Starter

    Joined:
    May 10, 2013
    Messages:
    10
    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.
     
  15. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    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.
     
  16. Sponsor

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/1098340

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice