Macros save the active sheet as a new workbook, ask the user about the location and delete macros from the new workbook

Question

I have a book with three worksheets: product, client, magazine. I need a macro assigned to a button in each of the sheets above. If the button is clicked by the user, then the active sheet should be saved as a new book with the following naming convention:

SheetName_ContentofCellB3_DD.MM.YYYY

Where

• The sheet name must be the name of the current active sheet
• ContentofCellB3 content of cell B3 active sheet every time
• DD.MM.YYYY current date

The following macro I wrote does the above:

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 problems that I would like to help you with:

• How can I change the above macro so that the user can decide the path where the new book will be saved?
• , , ?
• - ?

.

P.S. excel 2007 excel 2002

Answer 1

Lunatik, :

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

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

GetSaveAsFilename FALSE, . .

, Format(Date, "dd.mm.yyyy") .

Answer 2

. Application.GetSaveAsFilename, .

Chip Pearson, VBA , ,

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

, , ( !)

Answer 3

Another application: 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