macros将活动工作表保存为新工作簿，询问用户的位置并从新工作簿中删除macros

我有一个工作簿与三个工作表：产品，客户，日记。 我需要的是分配给上述每个表格中的button的macros。 如果用户点击该button，则活动工作表应按以下命名约定保存为新的工作簿：

SheetName_ContentofCellB3_DD.MM.YYYY

哪里

• SheetName应该是当前活动工作表的名称
• ContentofCellB3每次活动页的单元格B3的内容
• DD.MM.YYYY当前date

我写的下面的macros使上述：

 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 

结束小组

不过有一些问题，我希望你的帮助：

1. 我应该如何改变上面的macros，以便用户可以决定新的工作簿将被保存的path？
2. 我应该如何更改上面的macros，以便新的工作簿不会包含作为初始工作簿的工作表的一部分的任何macros？
3. 你看到我的macros中有什么可以做更好的方法吗？

感谢大家提前你的时间。

PS对于我的使用情况，必须始终保持从Excel 2007到Excel 2002的向后兼容性

Answer 1

为了搭载Lunatik的build议，你可以加上：

 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来允许用户提名一个path和文件名。

我已经使用了Chip Pearson的以下内容，将VBA从复制的工作簿中删除之前，它应该执行以下操作：

  Sub DeleteAllVBACode（）
         Dim VBProj As VBIDE.VBProject
         Dim VBComp As VBIDE.VBComponent
         Dim CodeMod作为VBIDE.CodeModule

        设置VBProj = myWorkbook.VBProject

        对于VBProj.VBComponents中的每个VBComp
            如果VBComp.Type = vbext_ct_Document那么
                设置CodeMod = VBComp.CodeModule
                用CodeMod
                    删除线1，.CountOfLines
                结束
            其他
                 VBProj.VBComponents.Remove VBComp
            万一
        下一个VBComp
    结束小组 

对不起，没有时间仔细检查你的代码（离开工作！）

Answer 3

另一个应用：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