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

Question

Hi everybody,

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_ContentofCellB3_DD.MM.YYYY

where

• 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"
WS.Copy
Application.WindowState = xlMinimized
ChDir MyPath

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

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 saved?
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 way?

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

Answer 1

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
            Else
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp
    End Sub

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

Answer 2

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.

Answer 3

Another appoach: SHBrowseForFolder

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
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, "")
   .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
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