Saving Active Sheet as Values only Worksheet in a newly created folder with dynamic name and location

[Focus27]

Hi Guys

I needed a macro to allow me to save a self populating form that use V Lookups to draw data from a tracker in a separate worksheet into a newly created folder and newly created file.

From couple of online solutions I have managed to create the below macro which works fine but creates some hiccups for me. It seems I need expert advice on how to tweak it.

The key problem is that when I run the macro all the Vlookups remain in the copied files creating links between the newly created form and the main tracker. I would like to tweak the macro that only values are saved (and obviously formats and columns widths) to preserve how the form looks.

2nd issue is that the macro is tied to the button on the spreadsheet which also appears on the newly created forms. Meaning that operators by accident can run the macro of the copy. Therefore I would like to save the file as non macro enabled spreadsheet but when I tried to change extension in the script below it would not work.

Can anyone help please?

Thank you !!!

Sub Export_1()

ActiveSheet.Copy   'creates an independent copy of the activesheet

Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Range("R5").Value ' New directory name

strFilename = Range("R7").Value 'New file name
' strDefpath = Application.ActiveWorkbook.Path 'Default path name
strDefpath = Range("R9").Value
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close  'close it and return to original workbook

End Sub

 

[John_w]

Try this:

Public Sub Export_2()

    Dim strFilename As String, strDirname As String, strPathname As String, strDefpath As String
    
    strDirname = Range("R5").Value  'New subdirectory name
    strFilename = Range("R7").Value 'New file name
    strDefpath = Range("R9").Value  'Base path
    
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub
    
    strDefpath = strDefpath & "\" & strDirname
    If Dir(strDefpath, vbDirectory) = vbNullString Then MkDir strDefpath
    
    strPathname = strDefpath & "\" & strFilename & ".xlsx" 'full file name
    
    ActiveSheet.Copy   'creates an independent copy of the active sheet
    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = ActiveWorkbook.Worksheets(1).UsedRange.Value
        'Delete command button which called this macro
        If Not IsError(Application.Caller) Then .Shapes(Application.Caller).Delete
    End With

    On Error Resume Next  'suppress error if workbook already exists and user clicks No or Cancel on 'replace it?' prompt
    ActiveWorkbook.SaveAs strPathname, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    ActiveWorkbook.Close SaveChanges:=False
    
    If MsgBox("Open " & strPathname & "?", vbYesNo + vbQuestion) = vbYes Then Workbooks.Open strPathname

End Sub

 

[Focus27]

Try this:

Public Sub Export_2()

    Dim strFilename As String, strDirname As String, strPathname As String, strDefpath As String
   
    strDirname = Range("R5").Value  'New subdirectory name
    strFilename = Range("R7").Value 'New file name
    strDefpath = Range("R9").Value  'Base path
   
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub
   
    strDefpath = strDefpath & "\" & strDirname
    If Dir(strDefpath, vbDirectory) = vbNullString Then MkDir strDefpath
   
    strPathname = strDefpath & "\" & strFilename & ".xlsx" 'full file name
   
    ActiveSheet.Copy   'creates an independent copy of the active sheet
    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = ActiveWorkbook.Worksheets(1).UsedRange.Value
        'Delete command button which called this macro
        If Not IsError(Application.Caller) Then .Shapes(Application.Caller).Delete
    End With

    On Error Resume Next  'suppress error if workbook already exists and user clicks No or Cancel on 'replace it?' prompt
    ActiveWorkbook.SaveAs strPathname, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    ActiveWorkbook.Close SaveChanges:=False
   
    If MsgBox("Open " & strPathname & "?", vbYesNo + vbQuestion) = vbYes Then Workbooks.Open strPathname

End Sub

Thank you very much John. Works like a treat and I love the question at the end whether you want to open newly created form.

Just a curved ball that transpired and which I am not sure can be fixed by a macro.

As couple of users were messing up the Vlookups overwriting them I had to protect the worksheet and lock the cells which are not meant to be edited. Because the macro won't run on the protected worksheet "as it is" I was wondering is there a code to unprotect the worksheet / run the macro / then protect the worksheet again? (There is no password set for protection)

Thank you.

 

[John_w]

Try this modified version which should work whether or not the sheet is protected.

Public Sub Export_2()

    Dim strFilename As String, strDirname As String, strPathname As String, strDefpath As String
    
    strDirname = Range("R5").Value  'New subdirectory name
    strFilename = Range("R7").Value 'New file name
    strDefpath = Range("R9").Value  'Base path
    
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub
    
    strDefpath = strDefpath & "\" & strDirname
    If Dir(strDefpath, vbDirectory) = vbNullString Then MkDir strDefpath
    
    strPathname = strDefpath & "\" & strFilename & ".xlsx" 'full file name
    
    With ActiveSheet
        'Temporarily unprotect sheet and copy it to a new workbook
        If .ProtectContents Then
            .Unprotect
            .Copy
            .Protect
        Else
            .Copy
        End If
    End With
    
    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = .UsedRange.Value
        'Delete command button which called this macro
        If Not IsError(Application.Caller) Then .Shapes(Application.Caller).Delete
    End With
    
    On Error Resume Next  'suppress error if workbook already exists and user clicks No or Cancel on 'replace it?' prompt
    ActiveWorkbook.SaveAs strPathname, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    ActiveWorkbook.Close SaveChanges:=False
    
    If MsgBox("Open " & strPathname & "?", vbYesNo + vbQuestion) = vbYes Then Workbooks.Open strPathname

End Sub

 

[Focus27]

Try this modified version which should work whether or not the sheet is protected.

Public Sub Export_2()

    Dim strFilename As String, strDirname As String, strPathname As String, strDefpath As String
   
    strDirname = Range("R5").Value  'New subdirectory name
    strFilename = Range("R7").Value 'New file name
    strDefpath = Range("R9").Value  'Base path
   
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub
   
    strDefpath = strDefpath & "\" & strDirname
    If Dir(strDefpath, vbDirectory) = vbNullString Then MkDir strDefpath
   
    strPathname = strDefpath & "\" & strFilename & ".xlsx" 'full file name
   
    With ActiveSheet
        'Temporarily unprotect sheet and copy it to a new workbook
        If .ProtectContents Then
            .Unprotect
            .Copy
            .Protect
        Else
            .Copy
        End If
    End With
   
    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = .UsedRange.Value
        'Delete command button which called this macro
        If Not IsError(Application.Caller) Then .Shapes(Application.Caller).Delete
    End With
   
    On Error Resume Next  'suppress error if workbook already exists and user clicks No or Cancel on 'replace it?' prompt
    ActiveWorkbook.SaveAs strPathname, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    ActiveWorkbook.Close SaveChanges:=False
   
    If MsgBox("Open " & strPathname & "?", vbYesNo + vbQuestion) = vbYes Then Workbooks.Open strPathname

End Sub

John, you are a pro. Thank you very much. Works like a treat.
Sorry for the delay but we had a customer audit last week so couldn't test it.

 

[Focus27]

Try this modified version which should work whether or not the sheet is protected.

Public Sub Export_2()

    Dim strFilename As String, strDirname As String, strPathname As String, strDefpath As String
   
    strDirname = Range("R5").Value  'New subdirectory name
    strFilename = Range("R7").Value 'New file name
    strDefpath = Range("R9").Value  'Base path
   
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub
   
    strDefpath = strDefpath & "\" & strDirname
    If Dir(strDefpath, vbDirectory) = vbNullString Then MkDir strDefpath
   
    strPathname = strDefpath & "\" & strFilename & ".xlsx" 'full file name
   
    With ActiveSheet
        'Temporarily unprotect sheet and copy it to a new workbook
        If .ProtectContents Then
            .Unprotect
            .Copy
            .Protect
        Else
            .Copy
        End If
    End With
   
    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = .UsedRange.Value
        'Delete command button which called this macro
        If Not IsError(Application.Caller) Then .Shapes(Application.Caller).Delete
    End With
   
    On Error Resume Next  'suppress error if workbook already exists and user clicks No or Cancel on 'replace it?' prompt
    ActiveWorkbook.SaveAs strPathname, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    ActiveWorkbook.Close SaveChanges:=False
   
    If MsgBox("Open " & strPathname & "?", vbYesNo + vbQuestion) = vbYes Then Workbooks.Open strPathname

End Sub

Hi John

I hope you are still around.

Couple of months down the line the original code works like clockwork but when I tried to apply the same macro to a similar spreadsheet I get below error which when I debug takes me to:
" .Shapes(Application.Caller).Delete" section.

I have tried to reasign the macro to the picture which triggers it but to no avail.
Interstingly enough if I press the button again on the "temporary created file" it works correctly. So it only crashes in the new spreadsheet.
Is there anything I can do to alleviate it.

Big Thx

 

[John_w]

If you debug the code you'll find that the name of the shape in the new workbook can be different to its name in the macro workbook, hence the code can't find the same shape. This happens if you delete shape(s) in the macro workbook so that when the sheet is copied to the new workbook the shapes have different names - Excel automatically numbers them 1, 2, 3, etc., for example "Button 1", "Button 2", "Picture 3".

Rather than looking for the clicked shape by its name, this code looks for it by its TopLeftCell position on the sheet. This should work as long as you don't have more than 1 shape with the same TopLeftCell.

Public Sub Export_2()

    Dim strFilename As String, strDirname As String, strPathname As String, strDefpath As String
    Dim clickedShape As Shape, thisShape As Shape
   
    strDirname = Range("R5").Value  'New subdirectory name
    strFilename = Range("R7").Value 'New file name
    strDefpath = Range("R9").Value  'Base path
   
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub
   
    strDefpath = strDefpath & "\" & strDirname
    If Dir(strDefpath, vbDirectory) = vbNullString Then MkDir strDefpath
   
    strPathname = strDefpath & "\" & strFilename & ".xlsx" 'full file name
   
    With ActiveSheet
        If Not IsError(Application.Caller) Then
            Set clickedShape = .Shapes(Application.Caller)
        Else
            MsgBox "This macro cannot be run directly.  It must be run from a Button (Form Control), Shape, Picture or Icon assigned to it.", vbExclamation
            Exit Sub
        End If
       
        'Temporarily unprotect sheet and copy it to a new workbook
        If .ProtectContents Then
            .Unprotect
            .Copy
            .Protect
        Else
            .Copy
        End If
    End With
   
    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = .UsedRange.Value
        'Find and delete the Shape which called this macro
        For Each thisShape In .Shapes
            If thisShape.TopLeftCell.Address = clickedShape.TopLeftCell.Address Then
                thisShape.Delete
                Exit For
            End If
        Next
    End With
   
    On Error Resume Next  'suppress error if workbook already exists and user clicks No or Cancel on 'replace it?' prompt
    ActiveWorkbook.SaveAs strPathname, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    ActiveWorkbook.Close SaveChanges:=False
   
    If MsgBox("Open " & strPathname & "?", vbYesNo + vbQuestion) = vbYes Then Workbooks.Open strPathname

End Sub

 

[Focus27]

Works a treat. Thank you very much John