Home » excel » excel – Macro to save active Sheet as new workbook, ask user for location and remove macros from the new workbook

excel – Macro to save active Sheet as new workbook, ask user for location and remove macros from the new workbook

Posted by: admin April 23, 2020 Leave a comment


I have a Workbook with three WorkSheets: Product , Customer, Journal.
What I need is a macro assigned to a button within each one of the above Sheets.
If the button is clicked by the user, then the active sheet should be saved as a new workbook with the following naming convention:



  • SheetName should be the name of the
    current active sheet
  • ContentofCellB3
    the content of cell B3 of the active
    sheet each time
  • DD.MM.YYYY the
    current date

The following macro I wrote makes the aforementioned:

Sub MyMacro()
Dim WS As Worksheet
Dim MyDay As String
Dim MyMonth As String
Dim MyYear As String
Dim MyPath As String
Dim MyFileName As String
Dim MyCellContent As Range

MyDay = Day(Date)
MyMonth = Month(Date)
MyYear = Year(Date)
MyPath = "C:\MyDatabase"

Set WS = ActiveSheet
Set MyCellContent = WS.Range("B3")

MyFileName = "MyData_" & MyCellContent & "_" & MyDay & "." & MyMonth & "." & MyYear & ".xls"
Application.WindowState = xlMinimized
ChDir MyPath

If CInt(Application.Version) <= 11 Then
    ActiveWorkbook.SaveAs Filename:= _
    MyFileName, _
    ReadOnlyRecommended:=True, _
    ActiveWorkbook.SaveAs Filename:= _
    MyFileName, FileFormat:=xlExcel8, _
    ReadOnlyRecommended:=True, _
End If

End Sub

However there are some issues I would like your help:

  1. How should I change the above macro so
    that the user can decide the path
    where the new workbook will be
  2. How should I change the above macro so that the new Workbook wont include any macros that were part of the sheet of the initial workbook?
  3. Do u see anything in my macro
    that could be done another better

Thanks everybody for your time in advance.

P.S. For my case of use there must always be a backward compatibility from excel 2007 till excel 2002

How to&Answers:

To piggyback on Lunatik’s suggestion, you might add this:

MyPath = Application.GetSaveAsFilename(FILEFILTER:="Excel Files (*.xls), *.xls", Title:="Something really clever about saving")

If MyPath <> False Then
    ActiveWorkbook.SaveAs (MyPath)
End If

GetSaveAsFilename returns FALSE if the user hits cancel. You can also supply a default filename.

This is a taste thing, but Format(Date, "dd.mm.yyyy") could replace your method.


The first one is simple. Use Application.GetSaveAsFilename to allow the user to nominate a path and filename.

I’ve used the following from Chip Pearson to strip the VBA out of a copied workbook before, it should do what you are after:

Sub DeleteAllVBACode()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule

        Set VBProj = myWorkbook.VBProject

        For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                Set CodeMod = VBComp.CodeModule
                With CodeMod
                    .DeleteLines 1, .CountOfLines
                End With
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp
    End Sub

Sorry, not got time to review your code in detail (leaving work!)


Another appoach: SHBrowseForFolder

Private Const MAX_PATH = 260

Private Declare Function SHBrowseForFolder Lib _
"shell32" (lpbi As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList Lib _
"shell32" (ByVal pidList As Long, ByVal lpBuffer _
As String) As Long

Private Type BrowseInfo
   hWndOwner As Long
   pIDLRoot As Long
   pszDisplayName As Long
   lpszTitle As Long
   ulFlags As Long
   lpfnCallback As Long
   lParam As Long
   iImage As Long
End Type

Private Function Show_Save_WorkSheet() As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo

szTitle = "Please, specify the location where you want the Worksheet to be stored"

With tBrowseInfo
   .hWndOwner = Me.hWnd
   .lpszTitle = lstrcat(szTitle, "")
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)

If (lpIDList) Then
   sBuffer = Space(MAX_PATH)
   SHGetPathFromIDList lpIDList, sBuffer
   sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)       
   Show_Save_WorkSheet = sBuffer
End If
End Function