首页 文章

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

提问于
浏览 次
3

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

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

结束子

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

  • 如何更改上述宏，以便用户可以决定新工作簿的保存路径？

  • 如何更改上面的宏以使新工作簿不包含作为初始工作簿工作表一部分的任何宏？

  • 你在我的宏中看到任何可以做得更好的方法吗？

感谢大家提前的时间 .

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

excel vba excel-vba

3 回答

  • 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") 可以取代你的方法 .

    回复于
  • 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

    抱歉，没有时间详细检查您的代码（离开工作！）

    回复于
  • 1

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

相关问题