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:
- How should I change the above macro so
that the user can decide the path
where the new workbook will be
saved? - 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
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
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：
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：
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
Tags: excelexcel
