Question

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

SheetName_ContentofCellB3_DD.MM.YYYY

其中

SheetName应该是的名称当前活动表
ContentofCellB3 活性细胞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

End Sub

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

我应该如何更改上面的宏用户可以决定路径新工作簿将在哪里保存？
如何更改上面的宏以使新工作簿不包含属于初始工作簿工作表的任何宏？
你在我的宏观中看到了什么这可以做得更好方式是什么？

提前感谢大家的时间。

P.S。对于我的使用情况，必须始终存在从excel 2007到excel 2002的向后兼容性

Answer 1

第一个很简单。使用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 2

捎带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 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

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

3 个答案: