vba 宏将活动工作表保存为新工作簿，询问用户位置并从新工作簿中删除宏
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/680875/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Macro to save active Sheet as new workbook, ask user for location and remove macros from the new workbook
提问by Harry
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
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
- SheetName 应该是当前活动工作表的名称
- ContentofCellB3 每次活动工作表的单元格 B3 的内容
- DD.MM.YYYY 当前日期
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
PS 对于我的使用情况，必须始终具有从 excel 2007 到 excel 2002 的向后兼容性
采纳答案by Ryan Shannon
To piggyback on Lunatik's suggestion, you might add this:
为了借鉴 Lunatik 的建议，您可以添加以下内容：
MyPath = Application.GetSaveAsFilename(FILEFILTER:="Excel Files (*.xls), *.xls", Title:="Something really clever about saving")
If MyPath <> False Then
ActiveWorkbook.SaveAs (MyPath)
End If
GetSaveAsFilenamereturns FALSEif the user hits cancel. You can also supply a default filename.
GetSaveAsFilenameFALSE如果用户点击取消，则返回。您还可以提供默认文件名。
This is a taste thing, but Format(Date, "dd.mm.yyyy")could replace your method.
这是一个品味的东西，但Format(Date, "dd.mm.yyyy")可以取代你的方法。
回答by Lunatik
The first one is simple. Use Application.GetSaveAsFilenameto allow the user to nominate a path and filename.
第一个很简单。使用Application.GetSaveAsFilename允许用户提名路径和文件名。
I've used the following from Chip Pearsonto strip the VBA out of a copied workbook before, it should do what you are after:
我之前使用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
Sorry, not got time to review your code in detail (leaving work!)
抱歉，没有时间详细检查您的代码（下班了！）
回答by Rodrigo
Another appoach: SHBrowseForFolder
另一个方法：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
