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
the content of cell B3 of the active
sheet each time
- DD.MM.YYYY the
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
However there are some issues I would like your help:
- How should I change the above macro so
that the user can decide the path
where the new workbook will be
- 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?
- 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
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
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 Else 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 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