宏将活动工作表另存为新工作簿，询问用户位置并从新工作簿中删除宏答案

【问题标题】：Macro to save active Sheet as new workbook, ask user for location and remove macros from the new workbook宏将活动工作表另存为新工作簿，询问用户位置并从新工作簿中删除宏
【发布时间】：2010-10-15 10:01:10
【问题描述】：

我有一个包含三个工作表的工作簿：产品、客户、日记。我需要的是分配给上述每个表格中的按钮的宏。如果用户单击该按钮，则应将活动工作表另存为具有以下命名约定的新工作簿：

SheetName_ContentofCellB3_DD.MM.YYYY

在哪里

SheetName 应该是当前活动工作表
CellB3 的内容活动单元格 B3 的内容每次工作表
DD.MM.YYYY 当前日期

我编写的以下宏实现了上述内容：

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

结束子

但是有一些问题我希望得到您的帮助：

我应该如何改变上面的宏所以用户可以决定路径新工作簿的位置保存了吗？
我应该如何更改上述宏，以使新工作簿不包含任何作为初始工作簿工作表一部分的宏？
你在我的宏中看到了什么吗这可以做得更好方式？

提前感谢大家的宝贵时间。

附：对于我的使用情况，必须始终具有从 excel 2007 到 excel 2002 的向后兼容性

【问题讨论】：

标签： vba excel

【解决方案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") 可以代替你的方法。

【讨论】：

在 2007 年以及更早的版本中，Excel 返回字符串 "False" 而不是布尔值 FALSE，因此您需要相应地更改代码，但除此之外应该可以正常工作.

【解决方案2】：

第一个很简单。使用Application.GetSaveAsFilename 允许用户指定路径和文件名。

我之前使用Chip Pearson 中的以下内容从复制的工作簿中剥离了 VBA，它应该可以满足您的需求：

Sub DeleteAllVBACode()
        将 VBProj 调暗为 VBIDE.VBProject
        将 VBComp 调暗为 VBIDE.VBComponent
        将 CodeMod 调暗为 VBIDE.CodeModule
        
        设置 VBProj = myWorkbook.VBProject
        
        对于 VBProj.VBComponents 中的每个 VBComp
            如果 VBComp.Type = vbext_ct_Document 那么
                设置 CodeMod = VBComp.CodeModule
                使用 CodeMod
                    .DeleteLines 1，.CountOfLines
                结束于
            别的
                VBProj.VBComponents.Remove VBComp
            万一
        下一个 VBComp
    结束子

抱歉，没有时间详细检查您的代码（下班！）

【讨论】：

我在引用中添加了可扩展性库，但在设置 VBProj 行上仍然出现错误。错误说“对象'_Workbook'的方法'VBProject'失败。我什至尝试用thisWorkBook替换myWorkbook

【解决方案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

【讨论】：